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1.  Introduction. 

Lattice  defects  in  or  on  crystalline  materials, 
determine  many  technologically  important  properties. 

Reliable  computer  simulations  of  such  defects  are  of 
potential  value,  and  may  be  expected  to  contribute  to  a 
fundamental  understanding  of  the  physical  processes  that 
determine  the  structure  and  properties  of  these  materials. 

In  the  case  of  point  defects,  it  is  attractive  to  use 
quantum  mechanics  to  describe  the  region  of  the  crystal  in 
proximity  to  the  defect,  perhaps  embedding  this  region  in  an 
external  potential  determined  by  some  auxiliary  principle. 
The  hope  here  is  that  the  response  of  the  lattice  to  the 
point  defect  may  then  be  described  by  some  method  which  is 
simpler  than  the  quantum  mechanical  method  used  to  describe 
the  point  defect  itself.  It  is  noted  parenthetically,  that 
the  definition  of  simpler,  as  used  here,  is  that  it  be 
computationally  less  expensive  to  use.  Similar 
considerations  apply  in  a  similar  way  to  the  case  of 
adsorbates  on  solid  surfaces.  Models  which  may  accurately 
describe  the  response  of  an  embedding  lattice  do  currently 
exist.  In  the  present  case  we  begin  our  development  for  the 
case  of  non-metals.  In  many  studies  performed  prior  to  the 
present  for  such  systems,  the  use  of  a  classical  shell 
model,  based  upon  point  charges,  and  masses,  interacting  by 
simple  parameterized  potentials  has  been  successful  in 
correlating  perfect-lattice  equilibrium  data  with  the  ground 
state  properties  of  defects  in  these  systems.1 '2  Therefore, 
we  begin  our  study  by  choosing  to  think  of  the  embedding 
lattice  in  terms  of  the  classical  shell  model.  We  find  that 
it  is  possible  to  retain  the  functional  form  of  the  shell 
model,  but  determine  all  needed  parameters  from  the  quantum 
mechanical  calculation,  and  to  augment  this  functional  form 
with  appropriate  angular  potentials  as  well.  The  region 
about  the  defect  can  be  described  by  means  of  an 
Unrestricted  Hartree-Fock  method.3  ( UHF )  Such  a  nr  del  will 
in  practice  not  yield  sufficient  accuracy  for  our  purposes, 
and  is  extended  by  the  implementation  of  a  Many-Body 
Perturbation-Theory  method  ( MBPT ) .  By  this  choice,  we  will 
separate  the  problems  of  exchange  from  those  of  correlation, 
rather  than  combine  them  as  is  often  the  case  in  a 
computation  based  on  the  density  functional  method.4 

In  the  case  of  a  cluster  embedded  in  a  classical 
lattice,  special  care  needs  to  be  taken  to  ensure  that 
mathematical  consistency  is  achieved  between  the  cluster  and 
the  embedding  lattice.  This  has  been  solved  formally  by  the 
work  of  Kunz  and  Klein,5  who  achieve  this  through  the 
introduction  of  a  localizing  potential,  here  called  the 
Kunz-Klein  localizing  potential  or  KKLP . 

Simulation  of  a  large  crystallite  or  an  infinite 
lattice  containing  a  point  defect  represented  by  a  cluster 
and  a  polarizable  embedding  lattice  is  implemented  here  by 


means  of  an  energy  minimisation  procedure.  That  is,  one 
minimizes  the  total  system  energy  with  respect  to  all 
parameters  that  define  the  lattice  and  the  electronic 
configuration.  For  those  parts  of  the  lattice  described  by 
the  shell  model,  one  must  minimize  the  total  energy  with 
respect  to  the  positions  of  the  ion  cores,  and  also  with 
respect  to  the  polarization  of  the  ions  individually.  For 
the  quantum  mechanical  cluster,  energy  minimization  is 
carried  out  with  respect  to  the  nuclear  positions  and  also 
the  electronic  configuration.  In  this  method  it  is  possible 
to  study  states  other  than  the  ground  state.  Since  the 
primary  physical  outputs  are  total  energies  and  geometries, 
spectroscopic  data  is  obtained  from  total  energy 
differences.  Positional  variations  are  carried  out  initially 
using  the  HADES  approach  as  implemented  in  the  ICECAP 
procedure,  or  more  recently  using  a  Monte  Carlo  approach. 

In  the  next  section  of  this  paper,  we  describe  the 
basic  theoretical  ideas  used  in  this  study.  This  will 
include  the  shell  model  lattice,  the  UHF  method,  the  KKLP 
and  the  inclusion  of  correlation  via  MBPT.  We  desired  to 
find  a  simple  molecular  system  which  might  illustrate  the 
essential  need  of  correlation  in  studies  of  binding 
behavior,  and  found  such  a  case  in  the  molecule  KrF2 .  In 
this  case  we  find  the  molecule  to  be  unbound  in  the  UHF 
limit,  but  is  strongly  bound  in  the  correlated  limit.  The 
strength  of  binding,  is  about  1  eV,  and  is  suggestive  that 
some  form  of  an  induced  giant  enhanced  polarizability  is 
responsible  for  this  binding  if  one  wishes  to  relate  this 
binding  to  a  van  der  Waals  model.  This  induced 
polarizability  must  be  generated  when  the  atoms  are  in 
proximity  to  each  other.  The  entire  methodology  is  extended 
to  considerations  of  the  case  of  a  simple  point  defect  case. 
This  is  the  substitutional  impurity  of  a  3d  transition  metal 
m  MgO.  Ground  state  studies  are  reported  here  for  V++,  Cr3  + 
and  Mn4+,  with  excited  state  results  obtained  as  well  for 
the  case  of  Cr3+.  The  more  complex  case  of  Cr3  +  in  AI2O3  is 
considered  as  well.  In  this  case  the  Cr  substitutes  for  an 
A1  ion,  and  the  lattice  is  found  to  relax  asymmetrically  in 
response  to  the  presence  of  the  Cr3+  impurity.  Given  the 
technological  importance  of  optical  properties  of  Ruby,  this 
ability  to  predict  asymmetric  relaxations  is  quite 
significant . 


2.  Theoretical  Methods. 


In  these  studies,  we  assume  that  we  have  a  system 
consisting  of  n  electrons  and  N  nuclei.  The  n  electrons  have 
coordinates  designated  by  jSi  and  mass,  m,  and  charge  e.  The 
nuclei  have  coordinate  Bi»  and  nuclear  charge  Zj.  In  these 
studies,  the  Born-Oppenheimer  approximation  is  used  and  thus 
the  nuclear  mass  is  treated  as  infinite.  The  electron 
coordinate  includes  spin  degrees  of  freedom.  In  general 
lower  case  letters  refer  to  electron  attributes,  while  upper 
case  letters  refer  to  nuclear  properties.  In  this  study  the 
atomic  system  of  units  is  used.  That  is;  Plank's  constant, 
the  electronic  charge,  and  the  electronic  mass  are  set  to 
unity.  Thus,  the  unit  of  length  is  approximately  0.53  x  10"8 
cm,  and  the  unit  of  energy  is  approximately  27.2  eV.  In  the 
usual  non  relativistic  formalism,  the  Hamiltonian  for  the 
system  is: 
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Ideally  one  would  like  to  solve  the  n-electron  Schroedinger 
equation  for  this  Hamiltonian: 


(2) 


but  computational  difficulties  preclude  this.  Instead  we 
will  resort  to  a  series  of  approximations  beginning  with  the 
UHF  approximation.  In  the  UHF  approximation,  the  n-electron 
wavefunction  is  approximated  by  an  antisymmetrized  product 
of  one  electron  orbitals.  These  orbitals  are  chosen  to  be 
orthonormal,  and  to  minimize  the  energy  expectation  value  of 
the  Hamiltonian  with  respect  to  the  functional  form  of  these 
orbitals.  This  set  of  approximations  leads  to  the  system  of 
equations  called  the  UHF  equations: 
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This  series  of  equations  may  be  solved  in  matrix  form  using 
a  basis  set  expansion  in  terms  of  contracted  gaussian  basis 
orbitals.  This  procedure  is  so  standard  as  to  require  no 
further  discussion  here. 

The  practical  problem  is  to  be  able  to  solve  this  set 
of  equations  for  extended  systems.  In  the  case  of  the  pure, 
perfect,  periodic  system,  techniques  of  energy  band  theory 
may  be  used7.  However,  we  wish  to  be  able  to  consider 
defects  as  well.  There  are  methods  to  study  some  defect 
cases  based  upon  periodic  super  cell  methods8,  but  in  our 
case  the  study  of  charged  defects  in  insulating  solids  is 
envisioned.  Such  studies  don't  lend  themselves  well  to  super 
cell  methods  due  to  the  infinite  range  of  the  coulomb 
potential.  Instead,  we  resort  to  the  older  method  of  local 
orbitals  introduced  formally  by  Adams9,  and  Gilbert10,  and 
given  a  computational  formulation  by  the  author11.  In  this 
method,  we  formally  divide  the  system  into  two  parts,  the 
cluster,  and  its  environment.  The  cluster  in  practice 
contains  the  defect  or  impurity  in  question  as  well  as  the 
first  few  shells  of  atoms  surrounding  the  defect.  The 
environment  contains  the  remainder  of  the  system. 


The  Hamiltonian  is  formally  partitioned  into  two  parts. 
Fa,  the  cluster  Hamiltonian,  and  VA,  the  Hamiltonian  for  the 
environment.  These  are  formally: 
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We  may  further  divide  the  term  VA  into  two  parts.  The  first 
is  due  to  the  ionic  nature  of  the  individual  atoms,  if  any, 
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and  is  called  VM,  and  the  part  due  to  the  non-ionic  nature 
of  the  atoms,  a  short  range  parr  termed  U^.  Having  done  this 
we  may  formally  consider  the  Adams-Gilfcert  modified  UHF 
equation: 

EF  *  (9) 


This  equation  is  simply  a  canonical  transformation  on  the 
original  UHF  equation1^,  and  its  solution  forms  a  first 
order  density  matrix  identical  to  that  of  the  original  UHF 
equation,  and  leaves  the  total  system  energy  unmodified. 
Thus : 
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The  presence  of  the  overlap  term  is  formally  required  since 
it  is  not  required  that  each  partitioning  of  the  system  have 
the  same  arbitrary  function  A  used  for  it.  Therefore,  the 
various  orbitals  need  not  see  the  same  Hamiltonian,  and  are 
therefore  not  necessarily  orthogonal. 


In  the  present  implementation,  one  will  chose  the 
arbitrary  operator.  A,  to  be  -U^.  Therefore,  we  solve  the 
one-electron  equation: 
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In  this  implementation  the  term  tends  to  cancel  the 

term  U^  in  the  original  UHF  operator,  and  allows  the  cluster 
to  localize  a  number  of  electrons  in  it.  The  remainder  of 
the  electrons  are  of  necessity  delocalized  into  the 
environment.  One  may  naturally  play  the  same  localization 
trick  on  the  environment  electrons  as  well. 

The  term  TV*?  is  called  the  KKLP  due  to  its 
operational  effect.  The  strategy  of  solution  is  as  follows: 
Begin  with  the  pure,  perfect,  periodic  lattice.  Divide  this 
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lattice  into  some  set  of  natural  building  blocks.  One’s 
intuition  will  normally  dictate  a  good  choice  of  building 
block.  For  example,  in  the  case  of  crystalline  NaCl,  a 
natural  set  of  building  blocks  are  the  systems  Na+,  and  Cl“. 
These  are  not  free  space  ions  but  rather  ions  self 
consistently  distorted  by  the  crystalline  environment,  we 
assume  that  the  orbitals  associated  with  ions  situated 
suitably  far  from  the  defect  are  the  same  as  for  the  ions  of 
the  pure,  perfect,  periodic  crystal.  We  do  not  assume  that 
they  sit  at  perfect  lattice  sites,  and  allow  the  potential 
due  to  them  to  be  further  modified  by  a  polarization 
contribution.  Using  this  environmental  solution,  the  set  of 
equations  (12)  may  be  solved  for  the  cluster.  Within  the 
cluster,  atomic  positions  and  symmetries  are  relaxed  to 
establish  a  minimum  in  total  energy  directly  from  the 
quantum  mechanical  problem.  The  atomic  positions  and 
polarizations  are  also  relaxed  in  the  environment  to 
minimize  total  system  energy.  This  is  not  done  at  the 
quantum  level,  however,  due  to  the  complexity  of  this 
system.  Here  we  resort  to  use  of  the  shell  model.  In  this 
model,  each  core  has  a  charge,  as  does  each  shell.  If  the 
atoms  are  ionized  these  charges  are  not  equal.  The  shells 
interact  with  their  core  by  a  harmonic  force,  providing  for 
atomic/ionic  polarizability.  The  shells  are  set  to  interact 
with  each  other  via  a  Buckingham  potential  in  addition  to 
the  electrostatic  potentials.  The  parameters  of  the 
Buckingham  potential,  the  harmonic  potentials  and  the  core 
and  shell  charges  may  be  found  from  fitting  experimental 
data.  Such  is  not  a  requirement,  and  these  may  be  obtained 
directly  by  calculation.  This  then  is  a  brief  description  of 
the  essential  features  of  the  method  termed  ICECAP3-3.  jn  the 
previously  implemented  ICECAP  code  the  positional  relaxation 
is  accomplished  by  application  of  a  conjugate  gradient 
procedure.  In  more  recent  developments,  we  accomplish  the 
positional  relaxation  by  means  of  a  Metripolous  procedure 
within  the  Monte  Carlo  methodology.  This  offers  several 
procedural  advantages.  In  this  method  getting  trapped  m 
local  minima  rather  than  absolute  minima  is  reduced  as  a 
hazard,  the  study  of  low  symmetry  situations  is  facilitated, 
and  the  inclusion  of  finite  temperature  effects  is 
accomplished. 

In  the  above  discussion,  we  used  the  one  electron 
approximation  exclusively.  This  is  found  to  be  of  inadequate 
precision  for  our  needs  and  therefore,  we  seek  to  include 
explicit  electron  correlation  in  the  cluster  computation. 

This  is  most  easily  achieved  by  the  use  of  a  MBPT  formalism. 
This  is  a  natural  choice  in  some  ways  for  a  solid  system  due 
to  the  simple  fact  that  the  MBPT  method  is  extensive  (size- 
consistent  ) 13 . 

The  essential  features  of  this  approach  are 
demonstrated  by  consideration  of  the  non-degenerate  state 
case.  Extension  to  a  degenerate  system  can  be  obtained  as 

7 


well,  although  the  practicalities  of  implementation  are  far 
less  simple.  In  any  event,  for  the  cases  needed  here  non¬ 
degenerate  perturbation  theory  is  adequate.  Consider  a 
Hamiltonian,  H,  which  is  partitioned  into  two  parts,  a  zero 
order  Hamiltonian,  Hq,  whose  eigenvalues  and  eigenvectors 
are  known,  and  a  perturbation,  V.  Thus: 


*n  -  <yD  t  v 

(12) 


and 


From  these  solutions  we  may  construct  the  eigenvalues,  and 
eigenfunctions  of  the  total  Hamiltonian.  That  is  we  formally 
solve  the  correct  equation: 

(is) 


finding  that 
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In  the  present  case  we  need  to  properly  pick  a  Hg.  This  is 
usually  chosen  in  such  calculations  to  be  the  sum  of  the  one 
body  UHF  operator,  as  m  Moeller-Plesset  perturbation 
theory,  however,  we  do  not  necessarily  knew  the  canonical 
UHF  solution,  only  a  canonical  transformation  of  it.  We 
therefore  know  only  the  eigenfunctions  and  eigenvalues  of 
the  Adams-Gilbert-Kunz  equation  (12).  We  chose  the  sum  of 
these  one  body  equations  to  be  our  zero  order  Hamiltonian. 
This  allows  a  formally  tractable  solution  to  be  obtained. 
This  solution  through  second  order  becomes  simply 
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This  is  the  correlation  correction  used  in  our  work  In  the 
next  section,  several  examples  of  this  method  are  discussed, 
including  several  simple  cases  to  further  graphically 
illustrate  the  utility  of  inclusion  of  correlation. 


3.  Some  Test  Cases. 
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A.  KrF2 ,  a  case  of  an  Enhanced  van  der  Waals  Bond. 

The  inclusion  of  correlation  effects  in  a  solid  state 
chemical  calculation  by  explicit  ab  initio  methods  is  both 
computationally  expensive  and  difficult  to  formulate. 
Therefore  it  is  desirable  to  give  an  illustration  of  the 
need  for  this  refinement.  In  general  the  only  obvious  case 
is  the  bonding  of  molecular  solids  such  as  the  solid  rare 
gasses.  In  such  a  case  the  bonding  per  molecule/atom  is  so 
small  that  the  bond  doesn't  survive  the  elevation  of  the 
system's  temperature  to  room  temperature.  Such  effects  are 
masked  by  more  dominant  forms  of  bonding  in  most  solid 
systems.  We  seek  to  find  a  case  where  correlation  is 
dominant.  Several  such  systems  are  thought  to  exist  in  the 
case  of  surface  physics,  for  example  the  case  of  the 
chemisorption  of  rare  gas  atoms  onto  metal  surfaces.  In  the 
case  of  the  adsorption  of  Xe  on  w  bonds  of  the  size  of  1.1 
ev/atom  exist.  It  is  true  that  other  systems  exhibit 
adsorption  strengths  on  the  order  of  typical  van  der  Waals 
bonds,  which  are  several  orders  of  magnitude  less 
strong.14'15'16  Here  we  seek  a  simpler  molecular  analog  to 
demonstrate  the  need  for  correlation.  Such  a  case  is 
presented  by  KrF2.  The  extension  to  the  adsorption  of  rare 
gasses  on  metals  is  possible  by  like  methods,  and  has  been 
accomplished  for  several  cases.17 

The  basis  set  chosen  to  represent  Kr  and  F  were 
obtained  by  using  the  best  set  from  Huzinaga18.  This  set  was 
immediately  enhanced  by  splitting  the  outer  s,p,d  orbital  on 
Kr  into  two  basis  functions,  and  by  splitting  the  outer  s, 
and  p  orbital  on  F  into  two  basis  functions.  In  addition 
s,p,d,f  polarization  primitive  gaussians  were  added  to  the 
Kr  set  and  polarization  s,p,d-  primitives  were  placed  on  both 
fluorines,  the  exponents  being  chosen  by  nonlinear 
variation.  This  basis  set  was  then  used  to  study  the 
possible  geometry  of  the  KrF2  molecule.  Initially  the 
geometry  was  studied  in  a  symmetric  linear  F-Kr-F  system,  in 
this  geometry,  it  was  determined  that  a  minimum  in  total 
energy  occurred  when  the  Kr-F  separation  was  3.6  au.  Having 
established  this  minimum,  its  stability  was  examined  with 
respect  to  changing  the  F-Kr-F  angle,  and  with  respect  to 
allowing  the  two  Kr-F  distances  to  vary  independently.  These 
studies  indicated  that  the  linear  F-KR-F  molecule  with 
identical  Kr-F  separation  was  in  fact  a  minimum  on  the 
potential  energy  surface. 

The  study  was  conducted  for  three  initial  wavefunction 
possibilities.  The  HF  level  trial  function  was  permitted  to 
be  a  triplet,  a  closed  shell  singlet  ( RHF ) ,  and  an  open 
shell  singlet.  For  large  Kr-F  separation,  the  lowest  energy 
state  was  the  open  shell  singlet.  This  was  a  two  determinant 
wavefunction,  at  the  independent  particle  level.  The  UHF 
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single  determinant  wavefunction  was  triplet  contaminated  to 
the  extent  of  25%.  The  triplet  lay  a  bit  above  the  open 
shell  singlet,  and  became  degenerate  with  it  by  the  time 
that  the  Kr-F  separation  became  10.0  au.  For  such  large 
separations  the  closed  shell  singlet  wavefunction  lay 
substantially  above  the  other  two  orbitals.  However  at  short 
Kr-F  distance  the  condition  became  otherwise.  At  a 
separation  of  about  3.9  au  these  states  would  have  been 
essentially  degenerate  if  such  a  degeneracy  were  allowed. 

For  shorter  distance  the  lowest  energy  state  is  the  closed 
shell  singlet.  This  state  has  a  minimum  energy  at  a 
separation  of  3.4  au  in  the  Hartree-Fock  case  and  at  3.6  au 
in  the  correlated  case.  There  is  a  substantial  difference  in 
the  two  cases  however.  The  HF  minimum  at  3.4  au  is  unbound 
with  respect  to  separation  into  atoms  by  3.30  eV,  whereas 
the  correlated  state  is  bound  by  an  amount  equal  to  1.09  eV. 
Thus  the  inclusion  of  correlation  effects  enhances  the 
energy  of  binding  of  KrF2  by  4.49  eV,  and  changes  the  system 
into  a  bound  molecule  from  an  unbound  one  ^he  potential 
energy  curve  for  the  KrF2  molecule  is  seen  with  and  without 
correlation  for  the  symmetric  linear  case  in  table  1,  for 
the  three  cases  discussed. 

It  is  possible  to  attempt  to  understand  the  large 
enhancement  of  the  correlation  energy  of  KrF2 •  Near  the 
bonding  distance  one  finds  that  the  lowest  singlet  has  a 
second  singlet  state  slightly  above  it  in  energy.  This 
second  singlet  forms  a  strong  configuration  interaction  with 
the  lower  one  and  promotes  the  enhanced  correlation  bond. 
Thus  this  is  an  example  of  a  molecular  system  exhibiting  a 
form  of  "giant  enhanced  van  der  Waals"  bond,  as  well  as  a 
qualitative  explanation  for  it. 


TABLE  1.  The  lowest  singlet  state  and  the  triplet  state 
potential  energy  surface  for  a  symmetric  linear  FKrF 
molecule  is  given.  Energies  are  with  respect  to  the  isolated 
atom  limit,  and  are  in  eV,  while  the  Kr-F  distance  is  in  au. 
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B.  Monte  Carlo  Study  of  NaF. 


Solid  NaF  was  studied  previously  as  a  host  system  for 
the  impurity  cu+.4  This  study  also  deduced  properties  such 
as  the  lattice  constant  of  NaF  using  the  HADES  approach. 
Buckingham  potentials  were  used  in  this  study.  We  repeat 
this  study  for  this  case  using  clusters  of  finite  size,  the 
same  potentials  and  a  Monte  Carlo  simulation.  This  is  acne 
as  a  function  of  cluster  size.  The  individual  atoms  were 
allowed  to  move  using  a  Monte  Carlo  method.  The  atom  to  be 
moved  was  chosen  at  random,  as  was  the  direction  and  length 
of  the  proposed  motion.  The  decision  to  accept  the  proposed 
motion  was  then  made  using  the  Monte  Carlo  method.  The  only 
deviation  from  this  ideal. is  that  a  maximum  possible 
displacement  is  imposed.  The  equilibrium  geometry  as  a 
function  of  ion  numbers  is  seen  in  table  2,  along  with  the 
relative  computer  run  time.  The  smallest  system  is  defined 
as  unit  run  time.  We  note  for  completeness  that  due  to  the 
inclusion  of  unshielded  ionic  potentials,  all  ions  interact 
with  all  others  here  and  our  algorithm  can't  benefit  from 
use  of  finite  range  potentials. 

TABLE  2.  The  equilibrium  bond  length  determined  by 
averaging  all  nearest  neighbor  bonds  for  finite  clusters  of 
NaF  are  given.  Lengths  are  in  au.  The  number  of  ions  studied 
are  included,  and  relative  run  times  are  given. 


Total  no.  of 
ions  used 

Average  1st 
neighbor  distance 

Relative 
run  time 
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95.5 

1000 

4.37 
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2331 
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c.  cr3+  in  Mgo. 

Luminescent  transitions  within  the  unfilled  3d  shell  of 
transition  metal  ions  in  insulating  crystals  are  of  much 
current  interest  for  example  as  tunable  four-level  laser 
systems.  In  this  section  we  chose  to  study  the  electronic 
properties  of  3d3  impurities  in  MgO.  One  such  impurity  is 
the  Cr3+  ion.  The  3d3  impurities  prefer  to  occupy  octahedral 
sites  m  insulators  as  is  known  from  EPR  studies.  The  one- 
electron  energy  levels  are  described  in  terms  of  a  doubly 
degenerate  set  of  orbitals,  the  eg  orbitals,  and  a  three 
fold  degenerate  set,  the  t2g  orbitals.  The  splitting  of 
these  orbitals  is  termed  10Dq  in  energy.  In  terms  of  the 


many  body  system,  the  ground  state  of  the  d3  system  is  an 
4  A 2g  state.  The  lowest  lying  excited  states  may  arise  out  of 
a  d-d  transition  and  be  4T2g  in  character,  or  may  arise  out 
of  a  d-s  transition  and  be  *Tig  in  character. 

The  molecular  cluster  embedded  in  the  classical  lattice 
consists  of  the  transition  metal  ion  and  the  6  surrounding 
0““  ions  at  sites  (aOO).  The  gaussian  basis  sets  for  the  3d 
ion  are  obtained  from  Huzinaga.18  In  addition  diffuse  s,p,d 
basis  functions  were  added  to  the  3d  ion's  set  to  allow  the 
description  of  the  excited  state.  The  0 —  sets  are  obtained 
using  the  procedure  of  Pandey  and  Vail.19  The  nearest- 
neighbor  distance  and  the  short-range  potentials  for  the 
embedding  lattice  used  in  our  ICECAP  procedure  are  taken 
from  Sangster  and  stoneham.20  The  calculations  performed  are 
with  the  inclusion  of  MBPT  corrections. 

Initially  one  considers  the  isolated  d3  impurity 
embedded  in  MgO  in  its  ground  state.  If  the  impurity  is  V++ 
then  the  lattice  exhibits  an  outward  displacement  of  2%  for 
the  nearest  neighbors  in  equilibrium.  This  relaxation  adds  a 
stability  of  0.07  eV  to  the  system.  The  case  of  Cr3+  is 
different.  This  is  a  positively  charged  center  in  the 
lattice.  In  this  case  the  nearest  neighbor  o —  relax  inward 
by  5%  of  the  nearest  neighbor  distance,  and  the  relaxation 
contributes  0.84  eV  to  the  stabilization  energy.  The 
impurity  Mg4+  causes  an  inward  relaxation  of  15%  and  further 
stabilizes  the  lattice  by  some  7.0  eV. 

Excited  state  energies  are  calculated  for  the  Cr3+ 
impurity  in  MgO.  The  Frank-Condon  principle  is  used  in  these 
calculations.  We  find  that  the  transition  energies  from  the 
4A2g  ground  state  to  the  4Tig  and  the  4T2g  states 
respectively  lie  at  1.62  eV  {490  nm)  and  at  2.50  eV  (77  nm) . 
Experimentally  Okada  et  al .  21  have  assigned  a  peak  at  445 
nm  to  the  4A2g-4Tig  transition.  A  further  peak  found  at  620 
nm  is  ambiguous  in  its  identification.  Further  studies  are 
needed  to  identify  the  origin  of  this  peak  and  to  further 
resolve  this  spectrum. 

D.  The  Cr3+  Impurity  in  AI2O3. 

The  Cr3+  ion  substitutes  for  Al  in  the  ruby  lattice 
(AI2O3),  in  a  way  that  is  neutral  with  respect  to  the 
lattice  unlike  Cr  in  MgO.  The  ruby  crystal  has  the  O 
forming  a  hexagonal  close  packed  sub-lattice.  The  Al  ions  on 
the  other  hand  only  occupy  2/3  of  the  available  sites  on  the 
potentially  close  packed  cation  sub-lattice.  Although  the  Cr 
ion  is  of  like  charge  to  the  Al  ion  it  replaces,  the  Cr3+ 
ion  is  substantially  larger  in  ionic  radius  than  is  Al3+. 

The  radii  are  0.064  nm  and  0.050  nm  respectively.  Thus  one 
may  expect  the  Cr  ion  to  dilate  the  lattice  in  its  vicinity. 
This  is  found  to  be  the  case  here.  The  lattice  arraignment 
is  best  seen  as  a  plane  of  O  in  a  hexagonal  close  packed 
array,  a  plane  of  Al  ions,  a  plane  of  O  ions,  a  plane  of  Al 
ions  one  will  be  replaced  by  a  cr  ion,  a  plane  of  O  ions,  a 
plane  in  which  the  Al  ion  is  missing,  and  has  an  empty  site, 
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and  this  structure  repeated.  Substitute  n  Cr  ion  for  the  A1 
ion  indicated  above  and  a  strong  asymmetric  relaxation 
occurs.  In  this  case  the  3  O  ions  m  the  plane  between  the 
Cr  ion  and  the  Al  ion  relaxes  0.6%  of  a  lattice  plane 
separation  toward  the  Al  ion  plane,  whereas  the  3  O  ions  in 
the  plane  between  the  Cr  ion  and  the  empty  site  relax  by  an 
amount  of  3.7%  toward  the  empty  site.  This  result  is 
significant  in  that  it  verifies  the  result  deduced  from 
experiment  in  which  ruby  crystals  with  high  Cr 
concentrations  exhibit  asymmetric  relaxations  about  the  Cr 
site,  namely  that  this  relaxation  would  also  occur  for  the 
case  of  dilute  Cr  concentration  as  well.  The  present  case  of 
only  a  single  Cr  impurity  represents  the  limit  of  the  dilute 
impurity  case 


4.  CONCLUSIONS. 


The  technique  which  we  term  ICECAP  for  studying  the 
properties  of  defects  in  solids  has  been  seen  to  produce 
useful  quantitative  predictions  of  spectroscopic  as  well  as 
ground  state  data.  We  have  also  seen  that  the  model  is 
capable  of  modification  to  use  a  Monte  Carlo  approach  for 
the  determination  of  geometric  positions  of  atoms  as  well  as 
their  polarization.  This  extension  allows  a  simple  extension 
of  the  ICECAP  technology  to  the  case  of  low  symmetry  or  to 
systems  with  line  or  planar  defects  (eg  surfaces, 
interfaces,  grain  boundaries).  The  model  is  systematically 
capable  of  development  so  that  all  parameters  needed  for  the 
HADES  model  portion  of  the  ICECAP  procedure  are  capable  of 
being  obtained  from  theoretical  calculations  rather  than 
from  experiment  as  has  been  done  initially.17  It  is  further 
seen  that  so  doing  has  the  advantage  of  not  only  extending 
this  procedure  to  systems  for  which  a  data  base  is 
nonexistent  but  also  extending  the  procedure  to  cases  for 
which  potential  parameters  obtained  from  experiment  are  not 
well  adapted  to  distortions  far  from  equilibrium.  Thus,  the 
theoretical  determination  of  atomistic  modelling  parameters 
is  more  accurate  for  the  determination  of  the  an-harmonic 
part  of  the  potential  than  the  use  of  experimental  data.  The 
inclusion  of  correlation  corrections  are  seen  as  essential 
if  one  is  to  achieve  high  precision  numerical  estimates  of 
spectroscopic  and  ground  state  properties.  We  see  that 
correlation  bonding  far  stronger  than  usual  van  der  Waals 
bonds  is  possible  and  likely  due  in  strength  due  to  near 
degeneracy  of  several  low-lying  singlet  configurations.  We 
also  find  that  studies  of  systems  with  complex  ground  states 
such  as  the  Cr++  impurity  are  easily  accomplished,  and  that 
asymmetric  lattice  relaxations  in  response  to  impurities  may 
be  described  within  this  theory. 

This  research  is  supported  by  the  U.  S.  Navy  Office  of 
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Derivation  of  interionic  potentials  using  embedded  quantum- 
mechanical  clusters:  Cation  and  anion  impurities  in  MgO 

Ravindra  Pandcy,  Jun  Zuo,  and  A.  Barry  Kunz 

Department  of  Physics,  Michigan  Technological  University,  Houghton,  Michigan  49931 
(Received  6  September  1989;  accepted  13  November  1989) 

The  icecap  methodology  is  used  to  derive  interionic  potentials  of  some  cation  and  anion 
impurities  in  MgO,  namely,  Li*,  Na*,  K\  Be2*,  H~,  S2',  and  O2'.  Analysis  is  given  of 
the  defect  energies  obtained  by  using  the  derived  impurity  potentials.  Based  on  the 
available  experimental  data,  comparison  is  made  to  justify  the  reliability  of  the  derived 
impurity  potential  for  Be2*.  The  calculated  activation  energy  for  Be2*  diffusion  comes 
out  to  be  1.54  eV  as  compared  to  the  experimental  value  of  1.60  eV,  which  is  considered 
to  be  very  satisfactory. 


1.  INTRODUCTION 

There  is  significant  interest  in  developing  reliable 
interionic  potentials  for  ionic  systems,  most  impor¬ 
tantly  the  oxides  and  related  ceramic  materials.  Magne¬ 
sium  oxide  (MgO)  is  such  a  technologically  important 
ceramic  with  applications  ranging  from  catalysis  to 
microelectronics.  It  is  a  simple  oxide  of  the  NaG  struc¬ 
ture  and  has  therefore  been  considered  as  the  proto¬ 
typical  oxide  for  both  experimental  and  theoretical 
studies  of  defect  properties  of  ceramic  materials. 

Interionic  potentials  of  ionic  crystals  are  generally 
derived  from  empirical  fittings  to  perfect  lattice  proper¬ 
ties.  such  as  cohesive  energies,  elastic  and  dielectric 
constants,  ensuring  that  the  potentials  are  compatible 
with  lattice  stability.1  This  approach,  however,  does  not 
provide  impurity  ionic  potentials  directly  since  it  relies 
heavily  on  the  availability  of  experimental  data.  One 
therefore  uses  an  arbitrary  averaging  method  to  extract 
impurity  potentials  from  host  lattice  potentials.  An 
alternative,  nonempirical  approach  is  to  obtain  the 
potentials  by  using  electron  gas  methods.  Here  the  inter¬ 
action  between  charge  densities  representing  the  inter¬ 
acting  ions  is  calculated,  the  densities  being  obtained 
by  calculating  the  wave  function  of  the  isolated  ion.1 
This  method,  however,  approximates  the  exchange  and 
correlation  potentials  and  does  not  allow  the  distor¬ 
tion  of  the  charge  densities  which  is  expected  for  the 
cases  of  highly  polarizable  anions.  Thus,  the  derivation 
of  reliable  impurity  potentials  has  so  far  proved  to  be 
a  difficult  task. 

With  the  availability  of  the  icecap  program  pack¬ 
age,2  we  have  undertaken  a  study  to  derive  reliable  im¬ 
purity  interionic  potentials  in  ionic  crystals.  In  earlier 
works,  we  derived  the  potentials  for  the  impurities, 
namely  Cu*  and  Ag*  in  some  alkali  halides,  concluding 
that  a  more  accurate  derivation  would  require  a  larger 
distortion  of  the  embedded  cluster.24  In  the  present 
work,  we  derive  interionic  potentials  for  impurities  using 
large  distortions  (typically  about  25%)  in  the  cluster  and 


then  use  them  to  obtain  defect  energies  in  MgO.  The 
impurities  considered  here  are  Li*,  Na*,  K*,  Be2*,  H~, 
and  S2',  substituting  the  host  cation/anion  in  MgO. 

Our  approach  has  been  to  dilate  and  compress  the 
quantum-mechanical  cluster  containing  the  impurity. 
Interionic  potentials  are  then  determined  such  that  the 
same  sequence  of  distortions,  applied  to  a  shell-model 
lattice  containing  the  impurity,  produces  the  same  en¬ 
ergy  variation.  In  all  cases,  the  embedding  lattice  is  fully 
relaxed.  In  Sec.  II  we  will  give  a  brief  description  of 
this  method  of  deriving  impurity  potentials.  In  Sec.  Ill 
we  will  present  and  discuss  our  results,  including  the 
derived  potentials,  defect  energies,  and  impurity  diffu¬ 
sion  in  MgO. 

II.  METHOD 

We  simulate  impurity-doped  MgO  in  icecap 
calculations  as  a  molecular  cluster  consisting  of  the  sub¬ 
stitutional  impurity,  its  nearest-neighbors,  and/or  second- 
nearest  neighbors  embedded  in  the  lattice  represented 
by  the  shell  model.5  icecap  combines  electronic  struc¬ 
ture  calculations  with  shell-model  treatment  of  lattice 
polarization  and  distortion,  with  the  electronic  structure 
and  lattice  relaxation  components  being  integrated  self- 
consistently.  The  icecap  methodology  is  described  in 
detail  in  a  variety  of  other  papers. 2A7  The  unrestricted 
Hartree-Fock  self-consistent  field  (UHF-SCF)  approxi¬ 
mation  is  employed  to  describe  the  electronic  structure 
of  the  molecular  cluster.8 

In  the  shell  model,  each  point-ion  consists  of  a  core 
of  charge  X  and  a  shell  of  charge  Y,  such  that  the  total 
ionic  charge  is  the  sum  of  the  core  and  shell  charges. 
The  ionic  polarization  is  described  by  the  displacement 
of  a  massless  shell  from  a  massive  core,  the  two  being 
connected  by  a  harmonic  spring  with  a  force  constant  K. 
The  polarizability  of  an  ion  is  then  given  by  Yl/K.  The 
interionic  potential  energy  may  then  be  expressed  as  a 
sum  of  pairwise  terms  of  the  form: 
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Ab  initio  study  of  localization  and  excitation  of  an  excess  electron  in  alkali  halide  clusters 
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(Received  5  February  1990) 

Hartree-Fock  calculations  coupled  with  second-order  many-body  perturbation  theory  have  been 
performed  to  study  binding  energies,  localization,  and  excitation  properties  of  an  excess  electron 
in  various  alkali  halide  dusters,  Na^F.-i,  Na„Cl.-i,  and  Li,F„-i  (n  —  2,  4,  5,  14).  The  binding 
energies  agree  well  with  recent  experimental  data  and  three  different  modes  of  localization  are 
corroborated.  The  position  of  the  /-center  absorption  band  in  Na„F„-i  clusters  is  verified,  but 
not  for  Na«CLi-i.  New  absorption  bands  for  Na„CL-i  and  LLF.-i  clusters  are  predicted. 


The  interest  in  the  physics  and  chemistry  of  small  clus¬ 
ters  is  rapidly  increasing  due  to  their  novel  and  hybrid 
properties.  Recent  experimental1-3  and  theoretical4,5 
work  focused  on  the  properties  of  an  excess  electron  at¬ 
tached  to  a  cluster  since  the  extra  electron  influences  the 
cluster  stability  and  therefore  the  reactive  properties. 
Honea  et  al. 1  have  measured  abundances  and  binding  en¬ 
ergies  of  an  excess  electron  interacting  with  (Na,F„- 1 ) + 
clusters.  Based  on  observed  abundances  and  ionization 
threshold  they  classified  the  clusters  as  follows:  cubic 
clusters  consist  of  a  filled  cubic  lattice  of  ions  with  the  ex¬ 
tra  electron  occupying  a  weakly  bound  surface  state;  F- 
center  clusters  consist  of  a  nearly  filled  cubic  lattice  with 
an  electron  localized  in  an  anion  vacancy;  and  noncubic 
clusters  have  the  excess  electron  bound  to  a  single  cation. 
The  F -center  and  the  noncubic  clusters  show  high  electron 
binding  energies.  As  further  evidence  for  electron  locali¬ 
zation,  Honea  et  al.  cite  the  observation  of  strong  optical- 
absorption  bands  in  /'-center  clusters  using  resonant  two- 
photon  ionization  spectroscopy. 

In  this  paper  we  report  results  of  an  ab  initio  study  of 
localization  and  excitation  properties  of  an  excess  electron 
attached  to  various  alkali  halide  clusters  and  provide  a 
basis  for  the  relation  between  binding  energies,  excitation 
energies,  and  the  degree  of  localization.  With  respect  to 
localization  properties,  we  find  good  agreement  with  ear¬ 
lier  theoretical  predictions4  5  based  on  quantum  path- 
integral  molecular-dynamics  calculations  and  corroborate 
the  interpretation  given  in  Ref.  1 .  The  calculated  binding 
energies  agree  well  with  the  experimental  data,  and,  for 
the  noncubic  cluster  NasFa,  are  in  better  agreement  than 
the  binding  energies  obtained  from  a  cruder  model. 1  For 
the  excitation  energy  we  verify  the  position  of  the  /'-center 
absorption  band  in  Na,F,-i  clusters,  but  cannot  support 
the  interpretation  that  the  observed  blue-green  band  in 
NajCl  cluster  is  associated  with  the  excitation  of  the  ex¬ 
cess  electron. 

Calculations  are  performed  for  various  Na„F*-i, 
Na,Cl,-i.  and  Li„F*-i  clusters  where  n  —2, 4,  5,  and  14. 
The  internudear  separation  between  cation  and  anion  in 
the  cluster  is  taken  to  be  the  same  as  in  bulk  solid  which  is 
3.80,  4.36,  and  5.31  bohrs  for  LiF,  NaF.  and  NaCl  clus¬ 
ters,  respectively.  {Preliminary  cluster-geometry  optimi¬ 
zation — only  bond  lengths,  but  not  bond  angles— shows 
the  lowering  of  total  energy  only  in  the  case  of  “ionized 
clusters.”  For  example,  the  (NajCI) +  cluster  relaxes  in¬ 


ward  to  the  bond  length  of  4.81  bohrs,  relative  to  the  bulk 
value  of  5.31  bohrs,  lowering  the  total  energy  by  0.1  eV. 
No  relaxation  of  cluster  geometry  from  the  bulk  separa¬ 
tion  has  been  found  for  the  neutral  clusters.] 

The  unrestricted  Hartree-Fock  linear  combination  of 
atomic-orbitals  method  is  employed.  Correlation  correc¬ 
tions  are  calculated  using  second-order  many-body  pertur¬ 
bation  theory.6  For  the  expansion  of  the  atomic  orbitals 
for  Na,  F,  and  Cl,  Huzinaga  Gaussian  basis  sets7  are  split 
into  contractions  of  (421/4),  (421/4),  and  (4321/43),  re¬ 
spectively.  For  Li,  a  (6,1)  basis  set*  is  used.  The  excess 
electron  in  the  /'-center  cluster  is  accommodated  by  add¬ 
ing  another  single  Gaussian  whose  exponent  is  determined 
variationally. 

Table  I  gives  the  binding  energy  of  the  excess  electron 
in  various  alkali  halide  clusters.  The  binding  energy  is 
defined  as  the  difference  between  total  cluster  energies  of 
a  neutral  cluster,  for  example,  Na„F,-i,  and  the  ionized 
cluster,  for  example  (Na„F,-i)+.  The  total  cluster  ener¬ 
gies  are  the  values  obtained  from  Hartree-Fock  calcula¬ 
tions  coupled  with  second-order  many-body  perturbation 
theory.  As  it  turned  out,  the  correlation  corrections  are 


TABLE  I.  Binding  energy  of  the  excess  electron  in  alkaii 
halide  dusters  calculated  by  Hartree-Fock  coupled  with 
second-order  many-body  perturbation  theory. _ 

Binding  energy  (eV) 


This  work 

Observed' 

Calculated* 

/-center  clusters 

NarCl 

4.06 

Na*Clj 

4.17 

.  .  . 

Na:F 

4.29 

3.85+0.15 

3.50 

Na4F3 

4.28 

3.54+0.15 

3.80 

LijF 

4.60 

LuFj 

4.73 

Noncubic  duster 

Na3F« 

3.80 

3.85+0.15 

3.10 

LisF< 

4.33 

Cubic  cluster 

NauFu 

1.88 

LiuFu 

1.20 

'Reference  1. 
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CHARACTERIZATION  OF  FLUORINE-DOPED 
MAGNESIUM  OXIDE: 

A  COMPUTER  SIMULATION  STUDY 


Ravindra  Pandey  and  A.  Barry  Kunz 

Department  of  Physics,  Michigan  Technological  University,  Houghton,  MI  49931,  U.S.A. 

( Received  30  October  1989;  accepted  24  January  1990) 

Abstract— A  computer  simulation  study  is  performed  to  characterize  F "-doped  MgO.  The  impurity 
potentials,  namely  F'-Mg3*  and  F’-O3'  art  derived  using  ICECAP  and  are  then  used  to  study  F* 
diffusion  in  MgO.  The  activation  energy  by  vacancy  mechanism  comes  out  to  be  1.53  eV.  The  exciionic 
state  associated  with  the  F  *  ion  is  also  studied.  Furthermore,  the  excess  electron  associated  with  the  F~  ion 
is  predicted  to  be  unbound  in  the  lattice. 

Keywords:  Magnesium  oxide,  computer  simulation,  diffusion,  charge  states. 
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I.  INTRODUCTION 

Fluorine  ions  are  found  to  be  effective  in  promoting 
densification  of  MgO  during  hot-pressing  or  sintering 
[1],  Furthermore,  an  F'  ion  substituting  O3'  in  MgO 
can  be  considered  as  an  analog  of  the  fission  product, 
I*  in  nuclear  fuel  oxides  such  as  U02.  Thus  there  is 
a  significant  interest  in  characterizing  fluorine-doped 
MgO  and  in  this  paper  we  intend  to  achieve  this 
objective  by  studying  optical  and  transport  properties 
of  fluorine  ion  along  with  its  different  charge  states  in 
MgO. 

Our  simulation  procedure  is  based  on  the 
embedded  cluster  model  using  the  program  package 
ICECAP  (ionic  crystals  with  electronic  cluster, 
automatic  program)  (2],  The  ICECAP  procedure  with 
its  long-range  lattice  relaxation  capability  is  ideal  for 
such  a  study.  In  Section  2  we  give  a  brief  description 
of  our  computational  model  simulating  the  impurity, 
F"  in  MgO.  The  results  are  presented  and  discussed 
in  Section  3,  and  summarized  in  Section  4. 


2.  COMPUTATIONAL  MODEL 

The  impurity,  fluorine,  in  MgO  is  considered  to 
occupy  the  on-center  position  as  F"  substituting  in 
the  lattice  for  the  O3"  ion.  Since  MgO  has  rock-salt 
structure  with  octahedral  site  symmetry,  F*  -doped 
MgO  is  modeled  in  ICECAP  as  a  defect  cluster  of 
F”  ions  at  the  duster  center,  six  nearest-neighbor 
Mg3*  ions  at  the  sites  (a,  a,  o)  and/or  12  next-nearest- 
neighbor  O3'  ions  at  the  sites  (a,  o,  o)  where  a  is  the 
nearest-neighbor  spacing.  In  this  way.  the  electronic 
structure  of  the  F~  ion  and  all  the  neighboring  ions 
that  are  assumed  to  be  significantly  affected  by  the 
F'  ion  are  described  quantum-mechanically. 

The  defect  cluster  is  embedded  in  the  classical  shell 
model  lattice  (3],  The  cluster  is  therefore  seen  by  its 


environment  as  a  Coulomb  potential  and  also  by 
means  of  short-range  interactions  of  the  cluster  ions 
with  the  shell  model  ions.  The  harmonic  distortion 
and  polarization  of  the  embedding  lattice  are  then 
determined  by  simulating  the  defect  cluster  by  a  set 
of  point  charges  whose  low-order  electrostatic 
multipoie  moments  match  those  of  the  defect  cluster. 
ICECAP  therefore  combines  electronic-structure 
calculations  with  the  shell  model  treatment  of  lattice 
polarization  and  distortion  in  a  mathematically  and 
physically  consistent  way.  (For  a  detailed  discussion, 
we  refer  to  Harding  er  al.  [2]  and  Pandey  and  Vail  [4].) 

In  the  shell  model,  each  point  ion  consists  of  a  core 
of  charge  x  and  a  shell  of  charge  y,  such  that  the  total 
ionic  charge  is  the  sum  of  core  and  shell  charges.  The 
ionic  polarization  is  described  by  the  displacement  of 
a  shell  from  a  massive  core;  the  two  being  connected 
by  a  harmonic  spring  with  a  force  constant  k. 

ICECAP  applies  the  minimum  energy  principle  to 
an  infinite  crystal  of  MgO  containing  the  defect.  The 
total  defect  crystal  energy  is  minimized  with  respect 
to  all  shell  and  core  positions  and  simultaneously 
with  respect  to  variational  parameters  in  the  defect 
cluster  wave  function.  This  minimization  is  updated 
while  the  nuclear  positions  of  the  defect  cluster  are 
varied  to  give  overall  minimization  of  the  total  defect 
crystal  energy.  That  is. 


cE  dE  6E_ 
Tk=~da  ~  dRe 


(1) 


This  results  in  obtaining  lattice  ( R ),  electronic  (<r), 
and  cluster  ( Rc )  configurations  and  the  total  defect 
crystal  energy  E. 

To  describe  the  electronic  structure  of  the  defect 
cluster,  we  use  the  unrestricted  Hartree-Fock  self- 
consistent  field  (UHF-SCF)  approximation  obtaining 
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The  valence-band  photoemission  of  silver  bromide  and  silver  iodobromide  has  been  measured 
with  use  of  synchrotron  raciation  in  the  region  of  the  Ag  4 d  Cooper  minimum.  The  large  change  in 
ionization  cross  section  in  this  region  permits  the  determination  of  the  individual  halogen  p  and 
silver  4 d  partial  densities  of  states  tPDOS).  The  energy-distribution  curves  (EDC’s)  were  recorded 
at  liquid-nitrogen  temperatures  to  prevent  photolysis  and  take  advantage  of  the  significant  line  nar¬ 
rowing  which  occurs  in  the  silver  halides  at  low  temperatures.  The  results  are  in  good  agreement 
with  experiments  using  rare-gas  resonance  lines  and  with  previously  calculated  energy-band  struc¬ 
tures.  Changes  in  the  halogen  PDOS  with  the  addition  of  iodide  indicate  that  the  narrowing  of  the 
band  gap  is  due  to  the  broadening  of  the  uppermost  antibonding  halogen  bands.  The  PDOS  were 
calculated  for  pure  AgBr  using  a  nonrelativistic,  self-consistent,  Hartree-Fock  theory  and  show 
good  agreement  with  the  experimental  results. 


I.  INTRODUCTION  of  states.  As  pointed  out  by  Wertheim,19  this  procedure 

should  have  wide  applicability  for  compounds  or  alloys 
In  the  alkali  halides  the  most  loosely  bound  electrons  containing  4d-or  5d-group  elements, 
on  the  halogen  and  the  alkali-metal  tons  are  well  separat-  In  the  silver  halides  the  procedure  for  determining  par¬ 
ed  in  energy.1-3  This  leads  to  a  relatively  simple  valence  tial  densities  of  states  is  somewhat  more  complex  than  in 

band  composed  almost  exclusively  of  halogen  p-like  orbit-  the  copper-gold  alloys.  Whereas  the  valence  Ag  4 d  orbit¬ 
als.  In  the  noble-metal  halides  the  situation  is  als  do  show  a  significant  Copper  minimum  at  around  130 

significantly  complicated  by  the  presence  of  the  metal  d  eV, 20-23  the  halogen  ionization  cross  sections  are  not 

orbitals  which  are  in  near  degeneracy  with  those  of  the  large  enough  to  produce  a  spectrum  characteristic  of  the 

halogen.4-18  This  near  degeneracy  leads  to  strong  hy-  pure  halogen  density  of  states.24  It  is,  however,  still  pos- 

bridization  and  considerable  complexity  in  the  valence-  sible  to  extract  the  partial  densities  of  states  from  mea- 

band  structure.  For  example,  in  the  rock-salt-structure  sured  EDCs.  It  is  only  necessary  that  the  ionization 

materials,  AgCl  and  AgBr,  this  orbital  mixing  has  pro-  cross  sections  be  known  and  that  the  relative  values 

found  effects,  causing  these  materials  to  have  indirect  change  significantly  with  photon  energy.  This  procedure 
bano  gaps  and  large  valence-band  widths.  In  the  context  was  pioneered  by  Cardona  and  co-workers  and  has  been 
of  photoemission  spectra,  this  mixing  means  that  applied  to  the  silver910  and  cuprous  halides,9  as  well  as 

valence-band  energy-distribution  curves  (EDC’s)  will  be  a  the  ternary  compounds  AgInTe2  and  CuInS2.23  More  re¬ 
composite  of  both  the  halogen  and  metal  partial  densities  cently,  the  partial  density  of  states  in  Cu75Pd25  has  been 

of  states  (PDOS’s).  The  relative  proportions  will  vary  ac-  determined  with  this  method  from  synchrotron-radiation 

cording  to  the  energy-dependent  ionization  cross  sec-  studies.26  The  basic  assumption  is  that  the  experimental 

tions.  In  an  ideal  case,  for  each  type  of  orbital  composing  intensity,  N(E,hv),  where  E  is  the  electron  kinetic  ener- 

the  valence  band  there  would  exist  a  photon  energy  or  en-  gy  and  hv  is  the  photon  energy,  is  related  to  the  ioniza- 

ergy  range  where  its  contribution  to  the  experimental  tion  cross  section  per  electron,  a,(hv),  and  the  partial 

spectrum  would  dominate.  By  recording  spectra  at  each  density  of  states,  p,iE),  by  the  simple  relationship 
of  these  energies,  all  of  the  constituent  partial  densities  of 

states  could  be  directly  measured.  This  ideal  situation  is  SiE,h  v)  =  C{E,hv)[pp{E)op(hv)+pd(E)od(hv)]  .  (1) 

closely  approximated  in  the  Cu-Au  alloys. 19  At  low  pho¬ 
ton  energies  the  EDC’s  reflect  mainly  the  Au  5 d  density  The  proportionality  constant,  C(E,hv),  contains  expen- 

of  states,  but  near  the  Au  5 d  Cooper  minimum,  at  about  mental  variables  such  as  photon  flux  and  analyzer 

160  eV,  the  EDC’s  are  due  primarily  to  the  Cu  4d  density  transmission  function  as  well  as  effects  due  to  the  electron 


42  2996 


©1990  The  American  Physical  Society 


/ 


I  3 


I 


Cluster  Modeling  of  Solid  State  Defects  and 
Adsorbates:  Beyond  the  Hartree-Fock  Level 

A.  BARRY  KUNZ 

College  ol  Engineering.  Michigan  Technological  University.  Houghion.  Michigan  49931 


Abstract 

The  use  of  finite  clusters  of  atoms  to  represent  the  physically  interesting  portion  of  a  condensed  matter 
system  has  been  an  accepted  technique  for  the  past  two  decades.  Physical  systems  have  been  stucied  in 
this  way  using  both  density  functional  and  Hartree-Fock  methodologies,  as  well  as  a  variety  of  empirical 
or  semiempirical  techniques,  in  this  article,  the  author  concentrates  on  the  Hartree-Fock  based  mrjiods. 
The  attempt  here  is  to  construct  a  theoretical  basis  for  the  inclusion  of  correlation  corrections  is  such 
an  approach,  as  well  as  a  strategy  by  which  the  limits  of  a  finite  cluster  may  be  transcended  in  such  a 
study.  The  initial  appeal  will  be  to  a  modeling  approach,  but  methods  to  convert  the  model  to  a  self- 
contained  theory  wtll  be  described.  It  will  be  seen  for  the  case  of  diffusion  of  large  ions  in  solws  that 
such  an  approach  is  quite  useful.  A  further  study  of  the  case  of  adsorption  of  rare  gas  atoms  on  simple 
metals  will  demonstrate  the  value  of  inclusion  of  electron  correlation. 

Introduction 

Lattice  defects  in  or  on  crystalline  materials,  often  in  combinations  that  are 
difficult  to  resolve  experimentally,  determine  many  technologically  important 
properties.  Reliable  computer  simulations  of  such  defects  are  of  potential  value, 
and  may  be  expected  to  contribute  to  a  fundamental  understanding  of  the  physical 
processes  that  determine  the  structure  and  properties  of  these  materials.  In  the  case 
of  point  defects,  it  is  attractive  to  use  quantum  mechanics  to  describe  the  region 
of  the  crystal  in  proximity  to  the  defect,  perhaps  embedding  this  region  in  an  external 
potential  determined  by  some  auxiliary  principle.  The  hope  here  is  that  the  response 
of  the  lattice  to  the  point  defect  may  then  be  described  by  some  method  which  is 
simpler  than  the  quantum  mechanical  method  used  to  describe  the  point  defect 
itself.  It  is  noted,  parenthetically,  that  the  definition  of  simpler,  as  used  here,  is  that 
it  be  computationally  less  expensive  to  use.  Similar  considerations  apply  in  a  similar 
way  to  the  case  of  adsorbates  on  solid  surfaces.  Models  which  may  accurately  describe 
the  response  of  an  embedding  lattice  do  currently  exist.  The  problem  becomes  to 
select  one,  and  define  fundamentally  how  to  link  such  a  model  with  the  quantum 
mechanical  cluster  model.  In  the  present  case  we  begin  our  development  for  the 
case  of  nonmetals.  In  many  studies  performed  prior  to  the  present  for  such  systems, 
the  use  of  a  classical  shell  model,  based  upon  point  charges  and  masses,  interacting 
by  simple  parametrized  potentials,  has  been  successful  in  correlating  perfect-lattice 
equilibrium  data  with  the  ground  state  properties  of  defects  in  these  systems  [1.2]. 
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Ab  initio  band-structure  calculations  for  alkaline-earth  oxides  and  sulfides 

Ravindra  Pandey,  J.  E.  Jaffe.  and  A.  Barry  Kunz 
Department  of  Physics,  Michigan  Technological  University,  Houghton.  Michigan  49931 
(Received  28  September  1990) 

The  electronic  structure  of  the  oxides  and  sulfides  of  Mg,  Ca,  and  Sr  is  computed  with  use  of  the 
self-consistent  Hartree-Fock  method  including  correlation.  Energy-band  structure  and  density  of 
states  are  presented  and  discussed  in  context  with  the  available  experimental  and  theoretical  studies. 
Our  results  predict  that  these  materials  (except  MgS)  are  direct-band-gap  materials. 


I.  INTRODUCTION 

Alkaline-earth  oxides  are  technologically  important 
materials  with  applications  ranging  from  catalysis  to  mi¬ 
croelectronics.  Alkaline-earth  sulfides  have  been  pro¬ 
posed  as  host  materials  for  device  applications  such  as 
multicolor  thin-film  electroluminescent  and  magneto¬ 
optical  devices. 1 

Recently,  Kaneko  and  his  co-workers:  have  measured 
the  optical  spectrum  of  Ca,  Sr,  and  Ba  chalcogenides. 
They  have  interperted  their  results  on  the  basis  of  a  self- 
consistent  augmented-plane-wave  (APW)  band-structure 
calculation  concluding  that  these  materials,  except  BaO, 
are  indirect-band-gap  materials  with  the  lowest  direct 
band  gap  at  the  X  point.  However,  a  more  detailed  look 
at  the  experimental  results  and  their  interpretation  re¬ 
veals  some  inconsistencies. 

(i)  The  appearance  of  the  two  groups  of  peaks  (as¬ 
signed  to  the  excitons  at  the  X  point  and  T  point,  respec¬ 
tively)  in  the  [imaginary  part  of  e(w)]  e:  spectrum 
showed  no  systematic  trend  in  the  oxides.  It  was  absent 
in  CaO  and  BaO,  but  was  present  in  SrO. 

<ii)  It  appears  that  the  direct  band  gap  in  these  materi¬ 
als  was  estimated  from  the  e:  spectrum  without  taking 
account  of  the  excitonic  binding  energy,  [see  Tables  I 
and  II  of  Ref.  2(a)]. 

(iii)  None  of  the  peaks  in  the  e2  spectrum  of  CaO  was 
assigned  to  the  T , 5- T ,  transition,  but  the  assignment  for 
the  higher-order  transition  and  r,5-r,:  was 

given. 

It  is  well  known  that  band-structure  calculations  based 
on  the  local-density  approximation  (LDA)  underestimate 
both  the  band  gap  and  the  valence-band  width.  Further¬ 
more.  the  drastic  lowering  of  the  d-like  conduction  level 
(relative  to  the  experiment)  at  the  X  point  (i.e.,  X})  has 
been  observed  in  the  LDA  results  for  ionic  materials  such 
as  NaCl.3  Hence  we  believe  that  the  reported  interpreta¬ 
tion  of  the  optical  spectrum  has  not  properly  taken  ac¬ 
count  of  the  inherent  limitations  of  the  LDA-based  calcu¬ 
lations  and  is  therefore  somewhat  ambiguous. 

To  provide  a  more  accurate  basis  for  the  interpretation 
of  the  optical  spectrum  of  these  materials,  we  have  under¬ 
taken  a  detailed  and  systematic  investigation  of  the  elec¬ 
tronic  structure  of  alkaline-ee^th  chalcogenides  using  the 
Hartree-Fock  method.  This  method  has  been  highly  suc¬ 


cessful  in  describing  the  electronic  structure  of  alkali  and 
silver  halides.3  The  present  work  focuses  on  the  nature  of 
the  energy  gap  of  the  oxides  and  sulfides  of  Mg,  Ca.  and 
Sr  only.  In  the  next  section,  we  give  a  detailed  account  of 
the  Hartree-Fock  method  including  electron-correlation 
effects.  In  Sec.  Ill  the  results  are  presented  and  com¬ 
pared  to  earlier  studies  involving  both  theory  and  experi¬ 
ment.  Finally,  conclusions  are  given  in  Sec.  IV. 


II.  THEORETICAL  METHOD 


The  basic  method  is  Hartree-Fock  and  we  begin  with 
the  canonical  Fock  equation, 

F^,(k,x,)=e,(kM,(k,xI)  ,  '2.1) 


where  the  one-electron  orbitals,  <b's.  are  constrained  to  be 
orthonormal  and  eigenstates  of  the  z  component  of  spin 
and  all  pertinent  crystal-symmetry  operations.  The  Fock 
operator  F  is  given  by 


F  = 


2m 


—e 


2 


I 


p(x,x') 
ir  —  r'i 


P(x',x)dx  , 


2.2) 


We  note  here  that  the  Fock  operator  is  a  unique  func¬ 
tional  of  the  first-order  density  matrix  p,  which  is  given 
by 


p(x,x')  =  2  ,  2.3) 

k  > 


where  the  sum  is  carried  over  all  occupied  orbitals. 

For  the  .V-eiectron-system  ground  state,  the  occupied 
one-electron  orbitals,  tb' s  are  the  ones  with  the  N  lowest 
values  of  the  Fock  eigenvalue  e, ( k).  In  the  context  of 
Koopemans  s  theorem,  the  eigenvalue  of  an  occupied  or¬ 
bital  e,  (k)  is  the  negative  of  the  energy  needed  to  remove 
the  electron  (occupying  the  /th  orbital)  from  the  crystal, 
and  the  eigenvalue  Ea(k)  for  a  virtual  (unoccupied)  orbit¬ 
als  is  the  negative  of  the  energy  gained  by  adding  an  elec¬ 
tron  to  the  crystal.  In  both  cases,  the  electronic  density 
of  the  remaining  electrons  is  unrelaxed.  Hence  the  phys¬ 
ics  here  refers  to  ionization  properties,  not  to  excitation 
properties  of  the  ,V-electron  system. 

The  self-consistent  solution  of  the  Fock  equation  '2.1) 
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Correlated  Hartree-Fock  Electronic  Structure  of  ZnO  and  ZnS 

J.  E.  Jaffe,  Ravindra  Pandey  and  A.  B.  Kunz 
Department  of  Physics,  Michigan  Technological  University,  Houghton,  Michigan  49931 

The  band  structures  of  ZnO  and  ZnS  have  been  calculated  by  an  all¬ 
electron  Hartree-Fock  method  including  correlation  corrections.  The  goal  is 
to  evaluate  the  applicability  to  polar  semiconductors  of  this  highly  efficient 
computational  method,  which  was  originally  designed  for  closed-shell  ionic 
systems,  and  to  study  the  role  of  Zn  3d-band  states  in  the  electronic  and 
optical  properties  of  these  materials.  Comparison  is  made  to  the  results  of 
other  calculations  and  to  optical  and  photoemission  data. 
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APPENDIX  A 

LISTING  OF  THE  MONTE  CARLO  COMPUTER  CODE 
Jun  2uo,  Author 


me. in  Thu  Apr  18  15:26:40  1991  1 

THIS  IS  THE  BEGINNING  OF  THIS  FILE. 

$$$$$$$$$$$$$$$$$S$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
Monte  Carlo  simulation:  NaF 

$$$$$$$$5$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 

THE  PRESET  PERCENTAGE  OF  ACCEPTANCE:  20 
THE  ACCURACY  OF  THE  POSITIONS:  1.0e-2 


$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 

THE  NUMBER  OF  IONS  PER  SIDE:  10 
PRINT  OUT  ALL  COORDINATES?  Y 


$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$??????????$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
THE  INITIAL  NEAREST  NEIGHBOR  SPACING  (  Bohr  ):  4.5 
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$????????$$$$$$$$$$$$ 


LATTICE  ION 

Na 

F 


CHARGE 

1 

-1 


POLARIZABILITY  (angstrom**3) 
0.196 
0.98 


$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 


THE  CENTRAL  ION:  Na 

NUMBER  OF  DEFECT  IONS:  0 


DEFECT  ION  CHARGE  POLARIZABILITY  POSITION  RELATIVE  TO  THE  CENTRAL  ION 

THE  SHORT  RANGE  POTENTIAL:  B*EXP  { -R/RHO)  -  C/R*M6)  +  1000000*CUT  (D) 

PARAMETERS  AND  UNITS: 


B: 

eV 

RHO:  Angstrom 

C:  eV* (Angstrom) 

*  *  6 

D:  Angstrom 

B 

RHO 

C 

D 

Na 

<> 

Na 

7895.4 

0.1709 

11.68 

0.8277 

Na 

<> 

F 

1594 . 2 

0.2555 

0 

0.1612 

F 

<> 

F 

1127.7 

0.2753 

11.68 

1.0208 

$$$$$$$$$$$$$$$$$$$$$$$$$$$$5$$$$$$$$$$$$$$$$$ S $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
THIS  IS  THE  END  OF  THIS  FILE. 
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C&>  A- 


£_]<sVW^ 


C 


c 


parameter (nmax-21 ) 
parameter (ndef»nmax*nmax*nmax) 

character*2  chn(lOO) 
character*3  norn(50) 
character*80  center_ion, title 
character* 80  defect_site (2) ,  ion (4) 

integer*4  ichoose (5, 5) ,  iorder (ndef ) ,  kind(ndef ) ,move (ndef ) 
real *4  a (15) , alpha (10),b(10),c(10),  charge (5)  ,d(10) , 
lp (3, ndef) .potential (1000000, 10) , randoml (97) , random2 (97) , 
2rho (10) , sroot (1000000) , x (ndef ) ,xtemp (ndef) , y (ndef) , 

3ytemp (ndef) , z (ndef) , ztemp (ndef) 
real *8  dum 


common  / character/center_ion,  title 
common  /chaarray/chn, defect_site, ion, norn 

common  /integer/icenter, ionedim, ipc, kind_of_center,  l.maxtrial, 
lmaxtrialp, move_total, move_tot alp, my above, myback, my below, my front, 
2myleft, my right, n_defects, n_kinds, n_per_layer, n_per_side, 
3n_points, n_points_ml, n_points_m2, n_t rials, n_trialsp, nlOO 
common  /iran/ial , ia2,ia3,icl, ic2, ic3, iseed, ixl, ix2, ix3, 
lml , m2 , m3 , negone 

common  /iarray/ ichoose, iorder,  kind, move 

common  / reall /accuracy, delta_e, all_charge, e_moveion, e_moveionp, 
le_total 

common  / real2 /pre_poa,  range 

common  /real3/spacing, trials, xnew, ynew, znew 

/rran/rmll, rml2,  rm2, rm3,  randoml, random2 
/ array 1 /a, alpha, b, c, charge, d, rho 
common  /array2/p 
common  /array3/potential 
common  /array4 /sroot 
/array5/x 
/array6/xtemp 
common  /array7/y 
common  /array8 /ytemp 
common  /array9/z 
common  /arraylO/ ztemp 


common 

common 


common 

common 


at 
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\A 


hn«A. 


PROGRAM  MC 
c 

c  The  program  picks  one  ion  at  a  time  randomly  and  tries  a  new  position.  All 
c  movable  ions  are  tried  in  one  iteration.  The  old  positions  are  replaced  with 
c  the  new  ones  at  the  end  of  each  iteration, 
c 

c  To  keep  the  lattice  from  rotating,  limitations  are  imposed  on  two  ions  so 
c  that  they  can  move  only  on  a  plane.  The  first  one  is  the  one  in  front  of  the 
c  central  ion,  which  can  move  only  on  the  x-y  plane.  The  second  is  the  one 
c  above  the  central  ion,  moving  only  on  the  x-z  plane, 
c 

c  After  each  iteration  (one  trial  for  each  movable  ion),  the  order  by  which  the 
c  ions  are  moved  is  shuffled  randomly, 
c 

c  When  a  new  position  is  determined,  it  is  stored  in  a  temporary  buffer.  The 
c  old  position  is  kept  until  all  movable  ions  are  tried.  This  treatment  is 
c  intended  to  simulate  the  instant  movement  of  the  ions.  And  with  this 
c  algorithm  the  program  can  be  easily  vectorized  and  parallelized, 
c 

c  For  each  iteration,  the  percentage  of  acceptance  (POA)  is  calculated.  If  the 
c  POA  is  larger  than  the  set  percentage  (in  the  input  file),  the  range  is 
c  reduced  by  the  amount  that  exceeds  that  percentage.  If  it  is  smaller  than 

c  that  percentage,  then  the  range  is  increased  by  the  amount  needed  to  make  up 

c  that  percentage, 
c 

c  This  program  is  for  calculating  ionic  crystals,  whose  experimental  value  of 
c  perfect  lattice  spacings  are  likely  known.  In  the  input  file,  the  known 
c  lattice  spacing  is  specified  as  the  initial  cation-anion  distance.  If  the 
c  experiment  value  is  not  available,  zero  (0)  should  be  specified.  The 
c  program  will  make  a  one-dimentional  estimate  and  use  that  estimate  as  the 
c  initial  cation-anion  distance, 
c 

c  This  version  of  the  program  takes  into  account  the  electronic  polarizations, 

c  This  is  done  in  two  stages.  The  first  stage  gives  an  estimate  of  the  ions 

c  positions  with  the  polarization  neglected  (to  save  time) .  In  the  second 
c  stage,  the  polarization  is  included, 
c 

include  'common. me' 
c 

real *4  finish (2) , start (2) , tl (2) , t2 (2) 
c 

data  decision/'NO' / 

data  ichoose/1,  2,  3,  4,  5, 

1  2,  6,  7,  8,  9, 

2  3,  7,10,11,12, 

3  4,  8,11,13,14, 

4  5,  9,12,14,15/ 

data  i seed, maxt rial, maxtrialp/-l, 10000,5000/ 
c 

gettime-etime (start) 
c 

call  getseed 
c 

open (unit-1, file-'me. in' ,  status-'  old' ) 
open (unit-2, f ile-'mc . res' ,  status-' unknown' ) 
c 

call  readin 
close (1 ) 

gettime-etime (t2) 
totherl-t2 (1) -start (1) 
tother2«t2 (2) -start (2) 
c 


gettime-etime (tl) 
call  maketable 


Q-3 
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gettime-etime (t2) 
tmaketablel-t2  (1)  -tl  (1) 
tmaketable2-t2 (2) -tl (2) 

gettime-etime (tl) 
if (ionedim. eq. 1 ) call  onedim 
gettime-etime (t2) 
tonediml=t2 (1) -tl (1) 
tonedim2=t2 (2) -tl (2) 

gettime-etime (tl ) 
call  lattice 
gettime-etime (t2) 
tlatticel=t2 (1) -tl (1) 
tlattice2*t2  (2) -tl  (2) 

gettime-etime (tl ) 
call  moveion 

if (charge (5) .eq. 0.0) then 
call  total_e 
else 

call  total_ec 
endif 

e_moveion-e_total 
gettime-etime (t2) 
tmoveionl=t2 (1) -tl (1) 
tmoveion2»t2 (2) -tl (2) 

gettime-etime (tl ) 
call  moveionp 
if (charge(5) .eq.0.0)then 
call  total_e 
else 

call  total_ec 
endif 

e_moveionp=e_total 
gettime-etime (t2) 
tmoveionpl=t2 (1) -tl (1) 
tmoveionp2=t2 (2) -tl (2) 

gettime-etime (tl ) 
call  output 
gettime-etime (t2) 
totherl*totherl+t2 (1) -tl (1) 
tother2=tother2+t2 (2) -tl (2) 

gettime-etime (finish) 

finish (1) -finish  (1) -start (1) 
finish (2) -finish  (2) -start (2) 
start (l)=100.0/finish(l) 
start (2) -100.0/ finish (2) 

cpu_seconds=tmaketablel 
r_minutes-cpu_second3/60 . OdO 
i_c pu_mi nu t e s - r _mi nut e s 

cpu_seconds__remaining=cpu_seconds-i_cpu_minutes*60 

r_hours-r_minutes/60 . OdO 
i_cpu_hours»r_hours 

minutes_cpu_remaining«i_cpu_minutes-i_cpu_hours*60 

system_seconds-tmaketable2 
r_minutes-system_seconds/60 . OdO 
i_system_minute3-r_minutes 

system_second3_remaining-system_3econds-i_system_minutes*60 
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r_hours*r_minutes/60 . OdO 
i_system_hours«r_hours 

minutes_system_remaining**i_system_minutes-i_system_hours*60 
write (2,2010) tmaketablel, tmaketable2, 

1  tmaketablel* start (1) ,  tmaketable2*start (2) , 

c  2i_cpu_minutes, cpu_seconds_remaining, 

c  3i_system_minutes, system_seconds_remaining, 

4i_cpu_hours,minutes_cpu_remaining, cpu_seconds_remaining, 
5i_system_hours , minutes_system_remaining,  system_seconds_remaining 
2010  format (///'EXECUTION  TIMES:'// 

lt22 , ' CPU  TIME'  ,t51,  'SYSTEM  TIME'// 

2  ' MAKETABLE : ' , tl7, f 12 . 2 , '  sec' , t46, fl2 . 2, 

3  '  sec' , lx, ' (' , f6.2, ' %,  ',f6.2,'%)'/ 

c  4tl5, i8, ' : ' , f 5 . 2, '  min:sec', 

c  5t44 , i8 , ' : ' , f 5 . 2, '  min:sec'/ 

6tl4 , i6, ' : ' , i2, ' : ' , f 5.2, '  hr s : min: sec' , 

7t43, i6, ' : ' , i2, ' :' ,f5.2, '  hrs:min:sec' /) 
c 

cpu_seconds=tonediml 
r_minutes=cpu_seconds/60 . OdO 
i_cpu_minutes=r_minutes 

cpu_seconds_remaining=cpu_seconds-i_cpu_minutes*6C 

r_hours=r_minutes/60 . OdO 

i_cpu_hours=r_hours 

minutes_cpu_remaining=i_cpu_minutes-i_cpu_hours*60 
system_seconds=tonedim2 
r_minutes=system_seconds/60 . OdO 
i_system_minutes=r__minutes 

system_seconds_remaining=system_seconds-i_system_minutes*60 

r_hours=r_minutes/60 . OdO 

i_system_hours«r_hours 

minutes_system_remaining*i_system_minutes-i_system_hours*60 
write (2,2020) tonediml , tonedim2, 

1 toned: ml ‘start (1 ) ,  tonedim2* start (2) , 
c  2i_cpu_minutes,  cpu_seconds_remaining, 

c  3i_system_minutes,  system_seconds_remaining, 

4i_cpu_hours, minutes_cpu_remaining, cpu_seconds_remaining, 
5i_system_hours ,  minutes_system_remaining, system_seconds_remaining 
2020  format ('ONEDIM: ' , 

It  17 , f 12 . 2, '  sec' , t46, f 12 . 2, '  sec' , lx, ' ( ' , f 6 . 2, ' % ,  ',f6.2,'%)'/ 
c  2tl5, i8, ' : ' , f 5 . 2, '  min: sec' , t44, i8, ' : ' , f 5 . 2, '  min:sec'/ 

3tl4, i6, ' :',i2,' : ' , f 5.2, '  hrs:min: sec' , 

4t43,  i6, '  :',i2,'  : ' ,  f  5 . 2, '  hrs  :min:  sec'  /). 

c 

cpu_seconds=tlatticel 
r_minutes=cpu_seconds/60 . OdO 
i_cpu_minutes*r_minutes 

cpu_seconds_remaining=cpu_seconds-i_cpu_minutes*60 

r_hours*r_minutes/60 . OdO 

i_cpu_hour3=r_hours 

minutes_cpu_remaining»i_cpu_minutes-i_cpu_hours*60 
sy3tem_seconds=tlattice2 
r_minutes=system_seconds/60 . OdO 
i_3ystem_minutes=r_minutes 

3ystem_3econds_remaining=system_seconds-i_system_ininutes*60 

r_hours=r_minutes/60 . OdO 

i_system_hours-r_hours 

minutes_system_remaining=i_system_minutes-i_system_hours*60 
write(2,2030)tlatticel,tlattice2, 
ltlatticel*start (1) , tlattice2*start (2) , 
c  2i_cpu_minutes,  cpu_seconds_remaining, 

c  3i_system_minutes,  3ystem_second3_remaining, 

4i_cpu_hours,minutes_cpu_remaining, cpu_seconds_remaining, 
5i_system_hours,  minutes_system_remaining, system_seconds_remaining 
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2030  format (' LATTICE: ' , 

ltl7, f 12 . 2, '  sec' ,t46,fl2.2, '  sec' , lx, '(' , f6.2, '%,  ',f6.2,'%)'/ 
c  2tl5, i8, ' : ' , f5.2, '  min: sec' ,  t44,  i8, '  : ' ,  f5 . 2,  '  min:sec'/ 
3tl4,i6,':',i2,':'/f5.2,'  hrs :min : sec' , 

4t43, i6, ' : ' , i2, ' : ' , f 5. 2, '  hrs:min:sec'/) 
c 

cpu_seconds-tmoveionl 
r_minutes=cpu_seconds/60 . OdO 
i_cpu_minutes=r_minutes 

cpu_seconds_remaining=cpu_seconds-i_cpu_minutes*60 

r_hours“r_minutes/60 . OdO 

i_cpu_hours»r_hours 

minutes_cpu_remaining=i_cpu_minutes-i_cpu_hours*60 
system_seconds=tmoveion2 
r_minutes=system_seconds/60 . OdO 
i_system_minutes=r_minutes 

system_seconds_remaining“system_seconds-i_system_minutes*60 

r_hours=r_minutes/60 . OdO 

i_system_hours=*r_hours 

minutes_system_remaining=i_system_minutes-i_system_hours*60 
write (2, 2040) tmoveionl,tmoveion2, 
ltmoveionl ‘start (1) , tmoveion2*start (2) , 
c  2i_cpu_minutes, cpu_seconds_remaining, 

c  3i_system_minutes, system_seconds_remaining, 

4i_cpu_hours,  minutes_cpu_remaining,  cpu_seconds_remaining, 
5i_system_hours,  minutes_system_remaining,  3ystem_seconds_remaining 
2040  format ('MOVEION: ' , 

ltl7, fl2 . 2, '  sec' ,t46,fl2.2,  '  sec' , lx, ' , f6.2, ' %,  f,f6.2,'%)'/ 
c  2tl5, i8, ' : ' , f 5 . 2, '  min: sec' ,  t44,  i8, '  : ' ,  f 5 . 2, '  min:sec'/ 
3tl4,i6,';',i2,' : ' , f5 . 2, '  hrs: min: sec' , 

4t43, i6, ' :',i2,' : ' , f5 . 2, '  hrs : min: sec' /) 
c 

cpu_seconds=tmoveionpl 
r_minutes=cpu_seconds/6C . OdO 
i_cpu_minutes=r_minutes 

cpu_seconds_remaining=cpu_seconds-i_cpu_minutes*60 

r_hours=r_minutes/60 . OdC 

i_cpu_hours=r_hours 

minutes_cpu_remaining=i_cpu_minutes-i_cpu_hours*60 
system_seconds*tmoveionp2 
r_minutes=system_seconds/60 . OdO 
i_system_minutes=r_minutes 

system_seconds_remaining=system_seconds-i_system_minutes*60 

r_hours=r_minutes/60 . OdC 

i_system_hours=r_hours 

minutes_system_remaining=i_system_minutes-i_system_hours*60 
write (2,  2050) tmoveionpl, tmoveionp2, 
ltmoveionpl*start (1) , tmoveionp2*start  (2) , 
c  2i_cpu_minutes, cpu_seconds_remaining, 

c  3i_system_minutes, system_seconds_remaining, 

4i_cpu_hours , minutes_cpu_remaining,  cpu_seconds_remaining, 
5i_system_hours, minutes_system_remaining, system_seconds_remaining 
2050  format ('MOVEIONP: ' , 

ltl7, fl2 . 2, '  sec' ,t46, fl2.2, '  sec' , lx, '  (' , f 6.2, ' %,  ',f6.2,'%)'/ 
c  2tl5, i8, ' : ' , f 5 . 2, '  min: sec'  ,  t44,  i8, '  : ' ,  f 5 . 2, '  min:sec'/ 

3tl4 , i6, ' :',i2,' : ' , f 5 . 2, '  hr3:min:sec', 

4t43,i6,' : ' , i2, '  : ' , f 5 . 2, '  hrs :min : sec' /) 
c 

cpu_seconds-totherl 
r_minutes»cpu_seconds/60 .  OdO 
i_cpu_minutes»r_minutes 

cpu_seconds_remaining«cpu_seconds-i_cpu_minutes*60 
r_hours“r_minutes/60 . OdO 
i_cpu_hours»r_hours 


me .  £ 


Thu  Apr  18  15:26:10  1991 


5 


minutes_cpu_remaining»i_cpu_minutes-i_cpu_hours*60 
system_seconds*tother2 
r_minutes»system_seconds/60 . OdO 
i_system_minutes«r_minutes 

system_seconds_remaining=system_seconds-i_system_minutes*60 

r_hours«r_minutes/60 .  OdO 

i_system_hours«r_hours 

minutes_system_remaining=i_system_minutes-i_system_hours*60 
write  (2, 2060) tot he rl,  tother2,  tot her 1* start ( 1 ) , t other 2* start  (2 ) , 
c  li_cpu_minutes, cpu_seconds_remaining, 

c  2i_system_minutes, system_seconds_remaining, 

3i__cpu_hours,  minutes_cpu_remaining,  cpu_seconds_remaining, 
4i_system_hours ,  minutes_system_remaining,  system_seconds_remaining 
2060  format ('OTHER: '  , 

1 1 17 , f 12 . 2, '  sec' ,t46,fl2.2, '  sec' , lx, '  ( ' , f 6 . 2, ' % ,  ',£6.2,'%)'/ 
c  2tl5, i8, ' : ' , f5 . 2, '  min : sec' , t44 , i 8 , ' : ' , f 5 . 2, '  min:sec'/ 

3tl4,i6,':',i2,':',f5.2,'  hrs :min : sec' , 

4t43,i6,' :',i2,' : ' ,f5.2, '  hrs:min:sec'/) 
c 

cpu_seconds=f inish (1 ) 
r_minutes=cpu_seconds/60 . OdO 
i_cpu_minutes*r_minutes 

cpu_seconds_remaining=cpu_seconds-i_cpu_minutes*60 

r_hours=r_minutes/60 .  OdO 

i_cpu_hours=r_hours 

minutes_cpu_remcining=i_cpu_minutes-i_cpu_hours*60 
system_seconds*=f  inish  (2) 
r_minutes=system_seconds/60 . OdO 
i_system_minutes=r_minutes 

system_seconds_remaining=system_seconds-i_system_minutes*60 

r_hours=r_minutes/60 .  OdO 

i_system_hours=r_hours 

rdnutes_system_remaining=i_system_minutes-i_system_hcurs*60 
write(2,2070)finish(l) ,finish(2) ,100.0,100.0, 
c  li_cpu_minutes, cpu_seconds_remaining, 

c  2i_system_minutes,  system_seconds_remair.ing, 

3i_cpu_hours , minutes_cpu_remaining, cpu_seconds_remaining, 
4i_system_hours, minutes_system_remaining,  system_seconds_remaining 
2C7C  format (' TOTAL: ' , 

lt!7, f 12 . 2, '  sec' , t46, f 12 . 2, '  sec' , lx, '  ( ' , f 6 . 2 , ' % ,  ',£5.2,'%)'/ 
c  2tl5,  i8, '  : '  ,  f  5 . 2, '  min:  sec' ,  t44,  i8, '  : ' ,  f  5. 2, '  rrdn:sec'/ 

3t 14, i6, ' :',i2,' : ' , f 5. 2, '  hrs :min : sec' , 

4t43, i6, '  :',i2,':',f5.2,'  hrs:min:sec') 

c 

all_3econds*f inish (1) +f inish (2) 
r_minutes=all_seconds/60 . OdO 
minutes=«r_minutes 

a  ll_seconds_rem.aining=all_seconds -minutes  *60 

r_hours=r_minutes/60 . OdO 

i_hours=r_hours 

minutes_remaining=mir.utes-i_hours*60 
write (2, 2080) all_seconds, 

1  i_hours, minutes_remaining, all_seconds_remaining 

2080  format (//'TOTAL  TIME: ' , 

Itl4,fl2 .2,'  sec  =  ',i7,'  hrs  :  ',i2,'  min  :  ',f5.2,'  sec') 
c 

end 
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SUBROUT I NE  CASECHANGE ( CHA , I ) 
character*80  cha 
do  10  k=l, 80 

if  (cha  (k: k) . eq. ' a' ) cha (k: k) =' A' 
if  (cha (k: k)  . eq. 'b' ) cha (k: k) ='  B' 
if (cha (k: k)  .  eq. '  c'  ) cha (k:  k)  ='  C' 
if (cha (k: k)  . eq. ' d' ) cha (k: k) =' D' 
if  (cha  (k:  k)  .  eq. '  e' )  cha  (k:k)  =  '  E' 
if  (cha  (k : k)  . eq. ' f' ) cha (k:k) ='F' 
if  (cha (k : k)  . eq. ' g' ) cha (k : k) =' G' 
if (cha (k: k) .eq. 'h' ) cha (k:k) ='H' 
if  (cha (k: k)  . eq. ' i' ) cha (k: k) ='  I' 
if (cha (k:k) .eq. ' j' ) cha (k: k) ='  J' 
if (cha (k: k) .eq. ' k' ) cha (k: k) ='  K' 
if (cha (k : k) .eq. ' 1' ) cha (k:  k)  ='  L' 
if  (cha (k: k)  . eq. 'm' ) cha (k:  k)  =  'M' 
if (cha (k: k) . eq. ' n' ) cha (k: k) ='  N' 
if (cha (k: k) . eq. ' o' ) cha (k: k) =' O' 
if (cha (k: k)  . eq. '  p' ) cha (k : k) =' P ' 
if  (cha(k-.k)  .eq.'q'  )  cha  (k:k)  =' Q' 
if (cha (k: k) . eq. ' r' ) cha (k: k) =' R' 
if (cha (k: k)  .eq.  '  s'  ) cha (k: k) =' S' 
if (cha (k: k)  . eq. ' t' ) cha (k: k) =' T' 
if (cha (k: k) .eq.'u') cha (k: k) =' U' 
if (cha (k: k) .eq.'v') cha (k:k) ='V' 
if (cha (k: k) .eq.'w') cha (k: k) =' W' 
if (cha (k: k) .eq. ' x' ) cha (k: k) ='X' 
if (cha (k: k) . eq. 'y' ) cha (k:k) =' Y' 
if  (cha (k: k)  . eq. ' z' ) cha  (k:k) =' Z' 
if (cha (k : k) .eq. ' (' ) i=k 
10  continue 
c 

i=i  +  l 
c 

return 


c 


end 
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SUBROUTINE  COUNT (CHA,  LAST ) 
C 

character*80  cha 
c 

do  1  k=l,80 

if (cha (k:k) .ne. '  ')last=k 
1  continue 

c 

return 

c 

end 
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c 

c 

c 


10 

c 


c 

c 


SUBROUTINE  CUTNULL (CHA) 
character*80  cha, temp 
ilst-0 

do  10  k-1,80 

if (ilst . eq. 0 . and. cha (k: k) .ne.' 

ilst-k 

endif 

if (cha (k : k) . ne . '  ' ) last=k 
continue 

if (il3t -eq. 0) last-0 
temp=cha (ilst : last) 
cha-temp 

return 

end 


' ) then 
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SUBROUTINE  E_CHANGE (II) 

C 

include  'common. me' 
c 

eold»0 . 0 
enew«0 . 0 
c 

do  10  j j»l,n_points 
if ( j  j . eq. ii) go  to  10 
dx=x (ii) -x ( j j) 
dy»y (ii) -y(  j j) 
dz«z (ii) -z ( j j) 
sr2mdx*dx+dy*dy+dz*dz 
if (sr2 . It . 1 . Oe+2) then 
kk=sr2* 10000+0 . 5 
sr=sroot (kk) 

el seif  (sr2 . It . 1 . 0e+4) then 
kk«sr2*l00+0.5 
sr*=10 . 0*sroot  (kk) 
elseif (sr2 . It . 1 . Oe+6) then 
kk“sr2+0 . 5 
3r«100 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+8) then 
kk=sr2*l . 0e-2+0 . 5 
sr»1000 . 0*sroot (kk) 
else 

write (2,2010) ii, j j,x(ii) ,x( j j) ,dx,y (ii) ,y ( j j) ,dy, 

1  z (ii) , z ( j j) ,dz, sr2 

2010  format (///' Sorry.  SROOT  is  not  large  enough  for  E_CHANGE.'// 

'i=',i4,'  j=',i4/ 

' x  (i) =' , f20 . 8, '  x(j)-',f20.8,'  dx-',f20.8/ 

' y  (i) *' , f20 . 8, '  y ( j ) =' , f20 . 8, '  dy=',f20.8/ 

4  ' z (i) =' , f20 . 8 , '  z ( j ) =' , f20 . 8 , '  dz=',f20.8/ 

5  ' sr2=' , f 20 . 8 ) 
stop 

endif 

if(sr.gt. 100.0) then 

eold=eold+a (ichoose (kind (ii) , kind( j j) ))/sr 
else 

kk=sr*10000 
if (kk.eq. 0) kk=l 

eold*eold+potential (kk, ichoose (kind (ii) ,  kind( j j) ) ) 
endif 

dx-xtemp (ii) -x ( j j) 
dy=ytemp  (ii) -y ( j j) 
dz=ztemp(ii) -z ( j j) 
sr2“dx*dx+dy*dy+dz*dz 
if (sr2 . It . 1 . 0e+2) then 
kk-sr2*10000+0.5 
sr=sroot (kk) 

elseif (sr2 . It . 1 . 0e+4) then 
kk-sr2*100+0.5 
sr-10 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+6) then 
kk=sr2+0 . 5 
sr-100 . 0*sroot (kk) 
elseif  (sr2 . It . 1 . Oe+8) then 
kk=sr2*l . 0e-2+0 . 5 
sr-1000 . 0+sroot (kk) 
else 

write (2, 2010) ii, jj,x(ii) , x ( j j) ,dx,y (ii) ,y ( j j) ,dy, 
z (ii) , z ( j j) ,dz,sr2 


1 


stop 

endif 


!>( 
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if  (sr .gt . 100.0) then 

enew»enew+a (ichoose (kind(ii) , kind( j j) ) ) /sr 
else 

kk-sr*10000 

if (kk.eq. 0) kk-1 

enew-enew+potential (kk, ichoose (kind(ii) ,kind( j j) ) ) 
endif 

10  continue 
c 

delta_e=enew-eold 

c 


return 
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SUBROUTINE  £_CHANGEC (II) 
c 

include  'common. me' 


eold-0 . 0 
enew-0 . 0 


do  20  j j-1, n_points 
if ( j j .eq. ii)go  to  20 
cS-0.0 

if (kind(ii) .gt.l0)then 
kind_ii-kind(ii) -10 
i f ( kind ( j  j ) . gt . 1 0 ) then 
kind_j j-kind( j j) -10 

c5=*a  (ichoose  (5,  kind_ii) )  +a  (ichoose  (5,  kind_j  j)  )  +a  (15) 
else 

kind_ j  j-kind ( j  j ) 
c5-a (ichoose (5, kind_j  j) ) 
endif 
go  to  10 
else 

kind_ii=kind (ii) 
endif 

if (kind ( j j) .gt . 10) then 
kind_ j  j«kind ( j  j ) -1 0 
c5-a (ichoose (5, kind_ii) ) 
else 

kind_ j j»kind ( j  j ) 
endif 

10  dx»x (ii) -x  ( j j) 

dy»y (ii) -y  ( j j) 
dz«z (ii) -z  ( j j) 
sr2=dx*dx+dy*dy+dz*dz 
if (sr2 . It . 1 . 0e+2) then 
kk»sr2*l 0000+0 . 5 
sro-sroot (kk) 
elseif (sr2 . It . 1 . Oe+4) then 
kk=sr2*100+0 . 5 
sro-10 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+6) then 
kk-sr2+0 . 5 
sro*100 . 0*s root (kk) 
elseif (sr2 . It . 1 . 0e+8) then 
kk-sr2*l . 0e-2+0 . 5 
sro-10 00 . 0*sroot (kk) 
else 

write (2,2010) ii, jj,x(ii)  ,x(jj) ,dx,y(ii) ,y(jj) ,dy, 

1  z  (ii) , z ( j j) ,dz, sr2 

2010  format (///'  Sorry.  SROOT  is  not  large  enough  for  E_CHANGEC . ' / / 

1  ' i»' , i4, '  j-',i4/ 

2  'x(i)-' , f20. 8, '  x ( j ) »' , f 20 . 8, '  dx-',f20.8/ 

3  ' y (i) , f2Q . 8, '  y ( j) , f20 . 8, '  dy-',f20.8/ 

4  ' z (i) , f20 . 8, '  z ( j ) •' , f20 . 8 , '  dz-',f20.8/ 

5  ' sr2-' , f20 . 8) 
stop 

endif 

if(sro.gt.l00 . 0) then 

eold-eold+a (ichoose (kind_ii, kind_j  j) ) /sro 
else 

kk-sro*10000 
if (kk.eq.O)kk-l 

eold-eold+potential (kk, ichoose (kind_ii,kind_j  j) ) 
endif 

dx-xtemp (ii) -x( j j) 
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dy-ytemp(ii) -y ( j j) 
dz-ztemp  (ii) -z  ( j j) 
s r 2 »dx *dx+dy * dy+dz * dz 
if (sr2 . It . 1 . Oe+2) then 
kk»sr2* 1000 0+0 . 5 
srn-sroot (kk) 
elseif (sr2 .It . 1 . 0e+4) then 
kk*sr2*100+0 . 5 
srn-10 . 0*sroot (kk) 
elseif  (sr2 . It . 1 . Oe+6) then 
kk=»sr2+0 . 5 
srn-100 . 0*sroot (kk) 
elseif  (sr2 . It . 1 . Oe+8) then 
kk*sr2*l . Oe-2+O . 5 
srn-1000 . 0*sroot (kk) 
else 

write (2,2010) ii, j j,x (ii) ,x ( j j) ,dx,y (ii) ,y ( j j) ,dy, 
1  z (ii) , z ( j j) , dz, sr2 

stop 
endif 

if(srn.gt. 100.0) then 

enew=enew+a (ichoose (kind_ii, kind_j j) ) /srn 
else 

kk=srn*10000 
if (kk.eq. 0) kk«l 

enew=enew+potential (kk, ichoose (kind_ii, kind_j  j ) ) 
endif 

if (c5 . ne. 0 . 0) enew=enew+c5/srn-c5/sro 
20  continue 
c 

delta_e=enew-eold 

c 

return 

c 

end 
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SUBROUTINE  E_CHANGEP (II) 
c 

include  'common. me' 


eold-0 . 0 
enew-0 . 0 


do  10  j j-l,n_points 
if ( j j .eq. ii) go  to  10 
dx-x (ii) -x ( j j) 
dy-y(ii)-y< jj) 
dz-z (ii) -z  ( j j) 
sr2=dx*dx+dy*dy+dz*dz 
if  (sr2 . It . 1 . 0e+2 ) then 
kk=«sr2*  10000+0 . 5 
sr«sroot (kk) 

el seif (sr2 . It . 1 . Oe+4 ) then 
kk=sr2*100+0 . 5 
sr»10 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+6) then 
kk=sr2+0 . 5 
sr=100 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+8) then 
kk*sr2*l . 0e-2+0 . 5 
sr=1000 . 0*sroot (kk) 
else 

write (2, 2010) ii, j j,x(ii) ,x( j j) ,dx,y (ii) ,y ( j j) ,dy, 

1  z (ii) , z ( j j) ,dz, sr2 

2010  format (///' Sorry.  SROOT  is  not  large  enough  for  E_CHANGEP . ' / / 

1  'i~',i4,'  j=',i4/ 

2  ' x (i) =' , f20 . 8, '  x ( j) , f20 . 8, '  dx-',f20.8/ 

3  'y(i)-',f20.8,'  y ( j) ,  f 20 . 8, '  dy-',f20.8/ 

4  ' z (i) =' , f20 . 8, '  z ( j)*' , f20. 8, '  dz=',f20.8/ 

5  'sr2«',f20.8) 
stop 

endif 

sr3*sr*sr2 

uvx*dx/sr 

uvy-dy/sr 

uvz»dz/sr 

pi_dotjp  j=p (1, ii) *p (1, j j) +p (2,ii) *p (2, j j) +p(3,ii) *p(3, j j) 
pi_dot_ri j^p (1, ii) *uvx+p (2, ii) *uvy+p (3, ii) *uvz 
p j_dot_ri j=p (1, j j) *uvx+p (2 , j j) *uvy+pC3, j j) *uvz 
w»  (pi_dot__p j-3 . 0*pi_dot_ri  j*p  j_dot_ri  j)  /sr3 
if (sr . gt . 100.0) then 

eold«eold+a (ichoose (kind (ii) , kind ( j j) ) ) /sr+w 
else 

kk«sr*10000 
if (kk.eq. 0) kk-1 

eold«eold+potential (kk, ichoose (kind (ii) , kind ( j j) ) )  +w 
endif 

dx-xtemp ( i i ) -x ( j  j ) 
dy-ytemp(ii) -y ( j j) 
dz«ztemp (ii) -z { j j) 
sr2-dx*dx+dy*dy+dz*dz 
if  (sr2 . It . 1 . 0e+2) then 
kk“sr2* 10000+0 . 5 
sr-sroot (kk) 

elseif (sr2 . It . 1 . Oe+4) then 
kk-sr2*100+0.5 
sr-10 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+6) then 
kk*sr2+0 . 5 
sr-100 . 0*sroot (kk) 
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elseif  (ar2 . It . 1 . Qe+8) then 
kk-sr2*l . Oe-2+O . 5 
sr-1000 . 0*sroot (kk) 
else 

write (2, 2010) ii, jj,x(ii) ,x(jj) ,  dx, y (ii) , y ( j j) , dy, 

1  z  (ii) , z < j j) ,dz, sr2 

stop 
endif 
sr3-sr*sr2 
uvx-dx/sr 
uvy-dy/ sr 
uvz»dz/sr 

pi_dot_ri j-p (1, ii) *uvx+p(2, ii) *uvy+p(3, ii) *uvz 
pj_dot_ri j-p(l, j j) *uvx+p(2, j j) *uvy+p (3, j j) *uvz 
w- (pi_dot__p  j-3 . 0*pi_dot_ri j*p j_dot_ri j ) /sr3 
if(sr.gt. 100.0) then 

enew-enew+a (ichoose (kind(ii) , kind( j j) ) ) /sr+w 
else 

kk-sr*l0000 
if (kk.eq. 0) kk-1 

enew=enew+potential (kk, ichoose (kind (ii) ,  kind( j j) ) )  +w 
endif 

10  continue 
c 

delta_e=enew-eold 

c 

return 

c 

end 
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c 

c 

c 


2010 


SUBROUTINE  E_CHANGEPC (II) 

include  'common. me' 

eold*0 . 0 
enew-0 . 0 

do  20  j j»l, n_points 
if ( j j .eq.ii)go  to  20 
cS-0.0 

if (kind (ii) .gt . 10) then 
kind_ii-kind(ii) -10 
if (kind( j j) .gt. 10) then 
kind_j j»kind( j j)  -10 

c5-a (ichoose (5, kind_ii) ) +a (ichoose (5, kind_j j) ) +a (15) 
else 

kind_ j  j»kind ( j  j ) 
c5-a (ichoose (5, kind_j j) ) 
endif 
go  to  10 
else 

kind_ii«kind(ii) 

endif 

if (kind(jj) .gt.lOJthen 
kind_j  j=*kind(  j  j)  -10 
c5=a (ichoose (5, kind_ii) ) 
else 

kind_j  j-kind ( j  j ) 
endif 

dx*x (ii)  -x  ( j  j) 
dy»y (ii) -y( j j) 
dz-z (ii) -z ( j j) 
sr2-dx*dx+dy*dy+dz*dz 
if  (sr2 . It . 1 . Oe+2) then 
kk=»sr2*  10000+0 . 5 
sro=sroot (kk) 
el seif (sr2 . It . 1 . 0e+4) then 
kk-sr2*100+0.5 
sro-l0.0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+6) then 
kk»sr2+0 . 5 
sro*100 . 0*sroot (kk) 
el3eif (sr2 . It . 1 . 0e+8) then 
kk-sr2*l . 0e-2+0 . 5 
sro-1000 . 0*sroot (kk) 
else 

write (2, 2010) ii, j j,x(ii) ,x( j j) ,dx,y (ii) ,y ( j j) ,dy, 

1  z (ii) , z ( j j) ,dz, sr2 

format (///' Sorry .  SROOT  is  not  large  enough  for  E_CHANGEPC. ' // 

1  'i-',i4,'  j«',i4/ 

2  '  x  (i )  *=' »  f  20 . 8, '  x(  j)=',f20.8,'  dx-',f20.8/ 

3  ' y (i) r  f 20 . 8, '  y ( j) , f 20 . 8, '  dy«',f20.8/ 

4  ' z (i) , f 20 . 8, '  z(j)-',f20.8,'  dz*',f20.8/ 

5  ' sr2“' , f20 . 8) 
stop 

endif 

sr3«sro*sr2 
uvx»dx/sro 
uvy-dy / Sro 
uvz-dz/sro 

pi_dot_pj-p(l,ii)*p(l, jj)+p(2,ii)*p(2, j j) +p (3, ii) *p <3, j j) 
pi_dot_ri j-p(l, ii) *uvx+p (2, ii) *uvy+p(3, ii) *uvz 
pj_dot_ri j-p(l, j j) *uvx+p (2, j j) *uvy+p(3, j j) *uvz 
w«  (pi_dot_p j-3 . 0*pi_dot_ri j*p j_dot_ri j ) /sr3 


3  7 


•_changepc .  t 


Thu  Apr  18  15:26:09  1991 


2 


20 

c 

c 

c 


if(aro.gt. 100.0) then 

eold-eold+a (ichoose (kind_ii, kind_j j) ) / sro+w 
else 

kk-sro*10000 
if (kk.eq. 0) kk«l 

eold«eold+potential (kk, ichoose (kind_ii, kind_j j) ) +w 
endif 

dx*xtemp (ii) -x ( j j) 
dy=»y  temp  ( ii )  -y  ( j  j ) 
dz«ztemp (ii) -z ( j j) 
sr2«dx*dx+dy*dy+dz*dz 
if (sr2 . It . 1 . 0e+2) then 
kk«sr2*10000+0.5 
srn«sroot (kk) 
el seif (sr2 . It . 1 . Oe+4) then 
kk«sr2*100+0. 5 
srn*10 . 0*sroot (kk) 
el seif (sr2 . It . 1 . 0e+6) then 
kk«sr2+0 . 5 

srn=100 . 0*sroot (kk)  • 
elseif (sr2 . It . 1 . 0e+8) then 
kk*sr2*l . Oe-2+O . 5 
srn»1000 . 0*sroot (kk) 
else 

write (2,2010) ii, j j,x (ii) , x ( j j) ,dx,y (ii) ,y ( j j) ,dy, 

1  z (ii) , z ( j j) ,dz, sr2 

stop 
endif 

sr3»srn*sr2 

uvx=dx/srn 

uvy»dy/srn 

uvz»dz/srn 

pi_dot_ri j-p (1, ii) *uvx+p (2,  ii) *uvy+p (3, ii) *uvz 
pj_dot_ri j=p(l, j j)*uvx+p(2, jj) *uvy+p(3, jj)*uvz 
w* (pi_dot_pj-3 . 0*pi_dot_ri j*p j_dot_ri j) /sr3 
if (srn.gt. 100.0) then 

enew~enew+a (ichoose (kind_ii,kind_j j) ) /srn+w 
else 

kk=srn*10000 
if (kk.eq. 0) kk=l 

enew=enew+potential (kk,  ichoose (kind_ii, kind_j j) ) +w 
endif 

if (c5 . ne -  0 . 0) enew=enew+c5/srn-c5/sro 
continue 

delta_e*enew-eold 

return 

end 
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c 


c 


2010 


subroutine  getp 

include  'common. me' 

data  pi4over3/4 . 1887902/ 

do  30  ii-l,n__points 
xp*0 . 0 
yp*0 .  O' 
zp-0.0 

do  20  j j-ii+l,n_points 
dx-x(ii) -x( j j) 
dy-y(ii)-y(j j) 
dz-z (ii) -z ( j j) 
sr2«dx*dx+dy*dy+dz*dz 
if  (sr2 . It . 1 . 0e+2) then 
kk=sr2*10000+0 . 5 
sr»sroot (kk) 

elseif (sr2 . It . 1 . Oe+4 ) then 
kk=*sr2*l00+0.5 
sr»10 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+6) then 
kk=sr2+0 . 5 
sr«100 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+8) then 
kk“sr2*l . Oe-2+O . 5 
sr*1000 . 0*sroot (kk) 
else 

write  (2, 2010) ii, jj,x(ii) ,x ( j j) , dx, y (ii) ,y ( j j) , dy, 

1  z (ii) , z { j j) ,dz, sr2 

format (///' Sorry .  SROOT  is  not  large  enough  for  GETP.'// 

1  'i-',i4,'  j=',i4/ 

2  ' x (i) =' , f2C . 8, '  x ( j) =' , f20 . 8, '  dx=',f20.8/ 

3  ' y (i) =' , f20 . 8 , '  y < j) =' , f20 . 8 , '  dy=',f20.8/ 

4  ' z  (i) =' , f20 . 8, '  z  < j)=' , f20. 8, '  dz=',f20.8/ 

5  ' sr2=' , f20 . 8 ) 
stop 

endif 

uvx=dx/ sr 

uvy=dy/sr 

uvz=dz/sr 

sr3~sr*sr2 

sr5=*sr2*sr3 

sr6=sr3*sr3 

if (kind(ii) .gt.l0)then 
kind_ii=kind (ii) -10 
else 

kind_ii*kind(ii) 

endif 

if (kind( j j) . gt . 10) then 
kind_ j  j*kind ( j  j ) -1 0 
else 

kind_ j  j-kind ( j  j ) 
endif 

p_plus«alpha (kind_ii) ‘charge (kind_j j) /sr3 

alpha_product«alpha (kind_ii) ‘alpha (kind_j j) 

p_minus— 2 . 0*alpha_product*charge (kind_ii) /sr5 

f-4 . 0*alpha_product/sr6 

pt_plu3-p_plus 

pt_minus-p_minus 

do  10  kk*l,6 

p_plus-f *p _plus 
p_minus“f *p_minus 

pt_plU3-pt_plU3+p_plU3 
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10 


20 


30 

c 

c 


pt_m±nus*pt_minus+p_minus 

continue 

pt«pt_plus+pt_minus 
xp«xp+pt*uvx 
yp-yp+pt*uvy 
zp=zp+pt*uvz 
continue 
p (1, ii) =xp 
p(2,ii)-yp 
p (3, ii) =zp 
continue 

return 

end 
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subroutine  getseed 
c 

include  'common. me' 
c 

ial-7141 
ia2«8121 
ia3-4561 
icl-54773 
ic2»28411 
ic3=51349 
ml-259200 
m2-143356 
m3=243000 
negone--l 
rml  1-1.0 /ml 
rml2-2 . 0/ml 
rm2=l . 0/m2 
rm3-l . 0/m3 
c 

read(5,  5010) i,  j,  k 
5010  format(tl2,i2,tl5,i2,tl8,i2) 
c 

if (i .eq. 0) i=333 
if ( j .eq. 0) j =3  3 
if (k.eq. 0) k=3 
c 

iseed-real (i) *real (k) /real ( j) 

c 

read (5, 5020, end-10) seed 
5020  format (e80.0) 

iseed-abs (seed) 

c 

10  if  (iseed. eq. 0 ) i seed-3333 
c 

ixl=mod (icl+iseed, ml) 
ixl-mod (ial *ixl+icl,  ml) 
ix2=mod(ixl,m2) 
ixl-mod (ial* ixl  +  icl ,  ml) 
ix3=mod(ixl,m3) 
do  20  k-1,97 

ixl-mod (ial* ixl+icl,  ml ) 
ix2=mod (ia2*ix2+ic2,m2) 
r=ixl+ix2*rm2 
randoml (k) =r*rmll 
random2 (k) =r*rml2+negone 
20  continue 
c 

return 

c 

end 
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c 

c 

c 


c 


c 


c 


10 

20 

30 

c 


SUBROUTINE  LATTICE 

include  'common. me' 

character*80  cha 

n_pe r_s ideml -n_pe  r_s ide - 1 
n_pe r_l  ay  e  r-n_pe  r_s ide *  n_pe  r_s ide 
n_po i nt s =n_pe r_l ay e r * n_pe r_s i de 
if (mod (n_points, 2) .eq. 0) then 
ieven=l 
else 

ieven— 1 
endif 

n_points_ml“n_points-l 

n_points_m2-n_points-2 

i cente r =n_pe r_s i de / 2  - 1  +mod  ( n_pe r_s ide , 2 ) 

icenter=icenter* (n_per_layer+n_per_side+l) +1 

myf ront=icenter+l 

myback=icenter-l 

mylef t=icenter-n_per_side 

my  right =icenter+n__per_side 

myabove=icenter+n_per_layer 

mybelow=icenter-n_per__layer 

if (kind_of_center.eq. 1) then 
kind_of_next«2 
else 

kind_of_next*l 

endif 

if (mod(icenter, 2) .eq. 0) then 
sign=l . 0 
else 

sign=-l . 0 
endif 


k-1 

do  30  iz=0, n_per_s ideml 
do  20  iy=0, n__per_sideml 
do  10  ix*0f n_per_s ideml 
x (k) =spacing*ix 
y (k) =spacing*iy 
z (k) =spacing*iz 
if (sign . gt . 0 . 0) then 
kind (k) =kind_of_next 
else 

kind (k) =kind_of_center 
endif 

iorder (k) =k 

all_charge=all_chatge+charge (kind(k) ) 

sign-sign 

i f ( ieven . eq . 1 ) then 

if  (mod (k,  n_per_side)  .eq.  0)  sign— sign 
if  (mod  (k,  n_per_layer)  .  eq.  0)  sign— sign 
endif 
k-k+1 
continue 
continue 
continue 

do  40  k«3,n_kinds 
km2”k-2 

cha»defect_site (km2) (1:1) 
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6010 


1 


6030 


1 


6040 


1 


6050 


1 


6020 


1 


if (cha.eq. 'C' ) then 
center_ion«ion (k) 

all_charge*all_charge-charge (kind(icenter) ) 

+charge (k) 

kind (icenter) -k 
go  to  40 
endif 

if (defect_site (km2) (1:1) .eq. ' F' ) then 

if (my front . It . 0 . or .my front . gt . n_points) then 
write (6, 6010) 

format (III'  Sorry.  The  FRONT  position  is  not  available.'///) 
stop 
endif 

all_charge=all_charge-charge (kind (myf ront) ) 

+charge (k) 

kind (myf ront) «k 
go  to  40 
endif 

if (defect_site (km2) (1:1) . eq.'L')then 

if (myleft . It . 0 . or .my left . gt .n_points) then 
write (6, 6030) 

format (///' Sorry .  The  LEFT  position  is  not  available.'///) 
stop 
endif 

all_charge=all_charge-charge (kind (myleft) ) 

+charge (k) 

kind (myleft ) *k 
go  to  40 
endif 

if (defect_site (km2) (1:1) .eq. 'R')then 

if (my right . It . 0 . or . myright . gt . n_point s ) then 
write (6, 6040) 

format (///' Sorry.  The  RIGHT  position  is  not  available.'///) 
stop 
endif 

all_charge=all_charge-charge (kind (myright) ) 

+charge (k) 

kind (myright ) =k 
go  to  40 
endif 

if (defect_site (km2) (1:1) .eq.'A')then 

if (myabove.lt . 0 . or .myabove . gt . n_points) then 
write (6,6050) 

format (///' Sorry.  The  ABOVE  position  is  not  available.'///) 
stop 
endif 

all_charge=all_charge-charge (kind (myabove) ) 

+charge (k) 

kind (myabove) =k 
go  to  40 
endif 

if (defect_site (km2) (1:2) . eq. ' BA' ) then 

if (myback . It . 0 .or .myback. gt . n_points ) then 
write (6, 6020) 

format (///' Sorry .  The  BACK  position  is  not  available.'///) 
stop 
endif 

all_charge=all_charge-charge (kind (myback) ) 

+charge (k) 

kind  (myback)  =>k 
go  to  40 
endif 

if (defect_site (km2) (1:2) .eq. ' BE' ) then 

i f  (mybelow .  It .  0 .  or .  mybelow .  gt .  n__points )  then 
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write (6, 6060) 

6060  format (///' Sorry .  The  BELOW  position  is  not  available.'///) 

stop 
endif 

all_charge«all_charge-charge (kind (mybelow) ) 

1  +charge(k) 

kind (mybelow) -k 
go  to  40 
endif 

write (6, 6070) 

6070  format (/// 

1  'Sorry.  One  of  the  positions  of  the  defect  ions  is  wrong.' 

2  //'The  correct  positions  are:'// 

3  'CENTRAL,  FRONT,  BACK,  LEFT,  RIGHT,  ABOVE,  and  BELOW.'// 

4  'These  positions  are  with  respect  to  the  central  ion.'///) 
stop 

40  continue 
c 

if (all_charge. eq. 0 . 0) go  to  90 
c 

n_pe r_sidem2=n_per_side-2 

n_f  a  ce_i  on  s  *n_jpo  i  nt  s -n_pe  r_s  i  dem2  *  n__pe  r_s  i  dem2  *  n__pe  r_s  i  dem2 
charge (5) — all_charge/n_f ace_ions 
all_charge»all_charge+n_face_ions*charge (5) 
k=l 

do  70  iz»0, n_per_sideml 
do  60  iy«0, n_per_sideml 
do  50  ix-0, n_per_sideml 

if(ix.eq.0.or.iy.eq.0.or.iz.eq.0.or. 

1  ix.eq.n_per_sideml.or. 

2  iy.eq.n_per_sideml.or. 

3  iz.eq.n__per_sideml)  kind(k)=kind(k)+10 
k=k+l 

50  continue 

60  continue 

70  continue 

do  80  j-1,5 

a (ichoose (5, j) ) ^charge (5) *charge ( j) 

80  continue 

c 

90  dum=x (icenter) 

x (icenter) =x (n_points) 
x (n_points) =dum 
dum=y (icenter) 
y  (icenter)  =*y  (n_points) 
y (n_points) "dum 
dum»z (icenter) 
z (icenter) »z (n_points) 
z (n_points) -dum 
idum=kind (icenter) 
kind (icenter) =kind (n_points) 
kind (n_points) -idum 
c 

return 
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SUBROUTINE  MAKETABLE 
C 

include  'common. me' 


c 

c 


10 

20 

c 

c 


real*8  r,r2,r6 
r-1 . Od-4 

do  20  i-1, 1000000 
sroot (i) *sqrt (r) 
do  10  j-1,10 

if (a ( j) .eq. 0 . 0)go  to  10 
if <b( j) .eq. 0 . 0) then 
if (r.lt.d( j) )then 

potential (i, j) *9. 99d99 
else 

potential  (i, j) “a  ( j) /r 
endif 
else 

r2*r*r 

r6«r2*r2*r2 

if (r . It . d ( j ) )then 

potential (i, j) =9. 99d99 
else 

potential (i, j) -a ( j) /r+b ( j) *exp (r*rho ( j) ) -c ( j) /r6 
endif 
endif 
continue 
r-r+1 . Od-4 
continue 

return 

end 
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subroutine  moveion 
c 

include  'common. me' 


c 

range-0. 1* spacing 
m-mod (100, n  jpoi nt  s_ml ) 
if (m.eq. 0) then 

nl00-100/n_points_ml 

else 

nl00-100 . 0/n_points_ml+l 
endif 

trials-nlOO*n_points_ml 

c 

10  continue 
c 

do  40  i— 1,  n_jpoints_ml 
c 

xtemp(iorder (i) ) =x (iorder (i) )+range*ran2 (dum) 
c 

if (iorder (i) .eq.myabove) then 
ytemp (iorder (i) ) *y (iorder (i) ) 
go  to  20 
endif 
c 

ytemp (iorder (i) ) -y (iorder (i) ) +range*ran2 (dum) 
c 

if (iorder (i) . eq. my front) then 
ztemp (iorder (i) ) =z (iorder (i) ) 
go  to  30 
endif 
c 

20  ztemp  (iorder  (i)  )-z  (iorder  (i)  )  +range*ran2  (dum) 

c 

30  if (charge (5) .eq. 0. 0) then 

call  e_change (iorder (i) ) 
else 

call  e_changec (iorder (i) ) 
endif 
c 

if (delta_e . ge . 0 . OdO) then 

xtemp (iorder (i) ) =x (iorder (i) ) 
ytemp (iorder (i) ) =y (iorder (i) ) 
ztemp (iorder (i) ) -z (iorder (i) ) 
go  to  40 
endif 
c 

move (iorder (i) ) -move (iorder (i) )+l 
totalmove-totalmove+1 
c 

40  continue 

c 

do  50  i=l, n_points_ml 
x (i) -xtemp (i) 
y (i) -ytemp (i) 
z  (i) -ztemp (i) 

50  continue 

c 

n_trials-n_trials+l 
if (n_trials.eq.maxtrial) return 
if (mod (n_t rials, nlOO) .eq. 0) then 
poa-totalmove/ trials 
amount-poa+pre_poa 
range- ( 1+amount ) * range 
if (range. It. accuracy) return 


+4  if/- 
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move_total-roove_total+totalmove 

totalmove*0 

endif 

call  shuffle 
go  to  10 
c 

end 


U1 
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1 


c 

c 

c 

10 

c 

c 

c 


c 


c 


c 

20 


c 

30 


c 


c 


c 

40 

c 


50 

c 


c 


subroutine  moveionp 
include  'common. me' 
range-0.3 
call  getp 

do  4  0  i-1,  n_points_ml 

xtemp (iorder (i) ) -x (iorder (i) )+ range *ran2 (dum) 

if (iorder (i) . eq.myabove) then 
ytemp (iorder (i) ) «y (iorder (i) ) 
go  to  20 
endif 

ytemp (iorder (i) ) =y (iorder (i) ) +range*ran2 (dum) 

if (iorder (i) . eq. my front) then 
ztemp (iorder (i) ) «z (iorder (i) ) 
go  to  30 
endif 

ztemp (iorder (i) )  -z (iorder (i) ) +range*ran2 (dum) 

if (charge (5) .eq. 0. 0) then 
call  e_changep (iorder (i) ) 
el3e 

call  e_changepc (iorder (i) ) 
endif 

if (delta_e. ge . 0 . OdO) then 

xtemp (iorder (i) ) -x (iorder (i) ) 
ytemp (iorder (i) ) -y (iorder (i) ) 
ztemp (iorder (i) ) »z (iorder (i) ) 
go  to  40 
endif 

move (iorder (i) ) =move (iorder (i) ) +1 
totalmove-totalmove+1 

continue 

do  50  i=l , n_points_ml 
x  (i) -xtemp (i) 
y(i) -ytemp (i) 
z (i) -ztemp (i) 
continue 

n_trialsp=n_trialsp+l 
if (n_trialsp. eq.maxtrialp) return 
if (mod(n_trialsp, nlOO) .eq. 0) then 
poa-totalmove/t rials 
amount-poa+pre_poa 
range- (1+amount) *range 
if  (range . It . accuracy) return 
move_t  ot  a lp-mo ve_t ot  al p+ 1  ot  a lmove 
totalmove-0 
endif 

call  shuffle 
go  to  10 

end 
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SUBROUTINE  NUMBER  (CHA,  I  OR,  REAL,  INTEGER) 
C 

include  'common. me' 


c 


c 


c 


character*80  cha,char 
integer*4  isign (2) ,nornend<50) 
real*8  after, before,  real,  sign 


data  chn/'0','l','2' 
1' 13 ','14', '15', '16', 
2'26','27','28','29', 
3'39','40','41','42', 
4' 52' , '53', '54', '55', 
5' 65', '66', '67', '68', 
6'78','79','80','81', 
7'  91' , '  92' , '  93' , '  94' , 


'3', 
17', 
30', 
43', 
56' , 
69', 
82', 
95', 


4', 

'5',' 

6' , '7' 

,'8' 

'9', 

'10' , 

'11', 

'12', 

18' 

,'19' 

,'20', 

'21' 

'22' 

,'23' 

,  '24' 

,'25' 

31' 

,  '32' 

,'33', 

'34' 

'35' 

,'36' 

,'37' 

,  '38' 

44' 

,'45' 

,'46', 

'  47' 

'48' 

,'49' 

,'50' 

,'51' 

57' 

,'58' 

,'59', 

'60' 

'61' 

,'62' 

,'63' 

,'64' 

70' 

,'71' 

,'72', 

'73' 

'74' 

,'75' 

,'76' 

,  '77' 

83' 

,'84' 

,'85', 

'  86' 

CO 

-4 

,'88' 

,  '89' 

,'90' 

96' 

,  '97' 

,'98', 

'  99' 

/ 

9 


data  norn/' 1st' , ' 2nd 
1'lOth', '11th', '12th' 
2'19th', '20th', '21st' 
3' 28th', '29th', '30th' 
4' 37th', '38th', '39th' 
5'46th', '47th', '48th' 


, ' 3rd' , ' 4th' , ' 5th' , ' 6th' , ' 7th' , ' 8th' , ' 9th' , 
'  13th' , ' 14th' , ' 15th' , ' 16th' , ' 17th' ,  '18th' , 

' 22nd' , ' 23rd' , ' 24th' , '25th' , '26th' , ' 27th' , 

' 31st' , ' 32nd' , ' 33rd' , ' 34th' , ' 35th' , ' 36th' , 

' 40th' , '41st' , ' 42nd' , ' 43rd' , ' 44th' , ' 45th' , 
'49th', '50th'/ 


data  nornend/3,  3,  3, 3, 3,  3, 3,  3,  3,  4, 4,  4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 
14,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4/ 

c 

C  DETERMINE  WHERE  THE  LAST  CHARACTER  IS. 


C 


1 


do  1  k-1,80 

if  (cha (k:k) ,ne. '  ’ ) last-k 
continue 


c  THE  ALLOWED  CHARACTERS  ARE  NUMBERS,  PLUS  OR  MINUS  SIGNS,  THE  DECIMAL  POINT, 
C  AND  THE  LETTERS  E(e)  AND  D (d) . 
c 

idore«0 
ipoint-0 
isign (1) -0 
isign (2) -0 
ndore-0 
npoint»0 
nsign-0 
c 

do  4  k»l,last 
c 

if (cha (k:k) . eq. ' +' .or. cha (k:k) . eq. ' -' )then 

nsign-nsign+l 

if (nsign.gt.2)then 

write  (6, 101) 

101  format  (////////////////////////) 
write  (6,201) cha (1 : last) , nsign 

201  format (' Sorry.  You  have  to  stop  here. '///'In  the  number  you  input: 

1' , a, ','//' there  are  at  least  ',i2,'  signs.  Only  two  signs  are  all 
2owed. ' //'Stop. ' /) 
stop 
endif 

isign (nsign) -k 
go  to  4 
endi  f 
c 

if (cha (k: k) . eq. 'D' .or .cha (k: k) . eq. ' d' . or . cha (k: k) . eq. ' E' 

1  . or . cha  (k: k) . eq. 'e' ) then 

ndore-ndore+1 
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if (ndore .gt . 1) then 
write (6, 101) 

write  <6/ 202) cha (1 : last) , ndore 

202  format (' Sorry .  You  have  to  stop  here.' ///'In  the  number  you  input: 

1' , a, ','//' there  are  at  least  D(d)s  or  E(e)s.  Only  one  D(d) 

2or  E(e)  is  allowed. '//' Stop. ' /) 

stop 
endif 
idore-k 
go  to  4 
endif 
c 

if (cha (k:  k) . eq. ' . ' ) then 
npoint«npoint+l 
if  (npoint .gt . 1) then 
write (6, 101) 

write(6,203)cha(l:last) , npoint 

203  format (' Sorry .  You  have  to  stop  here. '///'In  the  number  you  input: 
1  ', a, ','//' there  are  at  least  ',i2,'  decimal  points.  Thi3  is  not  a 
211owed. ' //' Stop. ' /) 

stop 
endif 
ipoint-k 
go  to  4 
endif 
c 

do  3  1-1,10 

if (cha (k:k) .eq.chn(l) )go  to  4 

3  continue 
c 

write (6,101) 

write (6, 204) cha  (l:last) ,norn(k)  (1 :nornend(k) ) 

204  format (' Sorry .  You  have  to  stop  here. '///'In  the  number  you  input: 

1  ' ,a, ' , ' //'the  ',a,'  character  is  not  allowed.'/// 

2 'The  allowed  characters  are:'// 

3'  Numbers'/ 

4'  Plus  or  minus  signs'/ 

5'  The  decimal  point'/ 

6'  The  letters  D(d)  and  E (e) ' ///' Stop. ' /) 

stop 
c 

4  continue 
c 

C  SEE  WHERE  THE  FIRST  SIGN  IS  IF  THERE  IS  ONE. 
c 

if (isign(l) ,lt.2)go  to  5 

if (isign (1) -1 . eq. idore) go  to  5 

write (6,101) 

write (6, 205) cha  (1 : last ) 

205  format (' Sorry .  You  have  to  stop  here. '///'In  the  number  you  input: 
1' , a, ','//' the  first  sign  is  not  the  first  character .' //'And  it  is 
2not  the  one  after  the  letter  D(d)  or  E(e)  either .'//' This  is  not 
Sallowed.  Stop.'/) 

stop 

c 

C  SEE  WHERE  THE  SECOND  SIGN  IS  IF  THERE  IS  ONE. 

C 

5  if (isign (2) .eq. 0)go  to  6 
if (isign (2) -1 . eq. idore) go  to  6 
write(6,101) 
write (6, 206) cha (1 : last) 

format (' Sorry .  You  have  to  stop  here. '///'In  the  number  you  input: 
1' ,a, ' , ' //'the  second  sign  is  not  right  after  the  letter  D(d)  or  E 

2  (e) . ' //' This  is  not  allowed.  Stop.'/) 


206 
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C  SEE  WHERE  THE  DECIMAL  POINT  IS  IF  THERE  IS  ONE. 

C 

6  if (ipoint.eq.O.or.idore.eq.O)go  to  7 
if (ipoint.lt. idore) go  to  7 

write (6, 101) 

write (6, 207) cha (1 : last) 

207  format (' Sorry .  You  have  to  stop  here. '///'In  the  number  you  input 
1' , a, ','//' the  decimal  point  is  after  the  letter  D(d)  or  E(e).'//' 
2This  is  not  allowed.  Stop.'/) 

stop 

c 

C  THE  LETTER  D (d)  OR  E(e)  CAN  NOT  BE  THE  FIRST  CHARACTER. 

C 

7  if (idore. eq. 1) then 
write (6,101) 

write (6,208) cha (1 : last) 

208  format (' Sorry .  You  have  to  stop  here. '///'In  the  number  you  input 
1' , a, ','//' the  first  character  is  the  letter  D (d)  or  E (e) . ' //'This 
2is  not  allowed.  Stop.'/) 

stop 

endif 

c 

C  GET  THE  NUMBER. 

C 

after-0 . OdO 
bef ore-0 . OdO 
ndecimal-0 
nexp-0 
c 

C  GET  THE  PART  OF  THE  NUMBER  BEFORE  THE  DECIMAL  POINT. 

c 

sign-1 . OdO 
ibegin=l 
c 

if (ipoint .eq. 1) go  to  14 
c 

if (isign (1 ) . eq. 0) go  to  8 


if (cha (1:1) .eq. 


) sign=-l . OdO 


if  (isign (1) .eq. 1) ibegin=2 

if (ipoint . ne . 0) then 
iend-ipoint-1 
go  to  9 
endif 

if (idore . eq. 0) then 

iend-last 

else 

iend-idore-1 

endif 


do  13  k-ibegin, lend 
do  12  1-1,10 

if (cha (k: k) . eq. chn (1) ) then 

if (1 .eq. l)go  to  11 

real-1. OdO 

do  10  m«l,iend-k 

real-real*10 

continue 

before-before+real* (1-1) 
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go  to  13 
endif 

12  continue 

13  continue 
c 

C  GET  THE  PART  OF  THE  NUMBER  AFTER  THE  DECIMAL  POINT, 
c 

14  if (ipoint .eq. last . or . ipoint+1 .eq. idore . or . ipoint . eq. 0) go  to  19 
c 

iend=idore-l 
if (idore.eq. 0) iend-last 
ndecimal-iend-ipoint 
c 

do  18  k»ipoint+l, iend 
do  17  1-1,10 

if (cha (k:k) .eq.chn(l) ) then 
if (l.eq.l)go  to  16 
real-1 . OdO 
do  15  m-l,iend-k 
real=real*10 

15  continue 

16  after-after+real* (1-1) 
go  to  18 

endif 


c 

c  GET 


continue 

continue 

THE  PART  OF  THE  NUMBER  AFTER  THE  LETTER  D (d)  OR  E(e) . 
if (idore. eq. 0 . or . idore .eq. last) go  to  25 


c 

C  GET 


nexpsign»l 

ibegin=idore+l 

if  (isign (2) .eq. 0) then 
if  (isign (1 ) . It . 2) go  to  20 

if  (cha  (isign  (1)  :  isign  (1) )  .eq. '  )  nexpsign— 1 

else 

if  (cha  (isign  (2)  :  isign  (2)  )  .eq. ' )  nexpsign— 1 
endif 

ibegin-idore+2 

do  24  k-ibegin, last 
do  23  1=1,10 

if (cha (k: k) . eq. chn (1) ) then 

if (1 .eq. 1 ) go  to  22 

n-1 

do  21  m»l,last-k 

n=n*10 

continue 

nexp=nexp+n* (1-1) 

go  to  24 

endif 

continue 

continue 

THE  WHOLE  NUMBER  TOGETHER. 

do  26  k-l,ndecimal 
before-before* 10 
continue 


real-af ter+before 


number. £ 


Thu  Apr  18  15:26:10  1991 


5 


ndecimal«nexpsign*nexp-ndecimal 

c 

do  27  k-1, iabs (ndecimal) 
if (ndecimal .gt . 0) then 
real-real*10 
else 

real-real/10 

endif 

27  continue 
c 

real-sign* real 
c 

if (ior.ne.l) return 
c 

c  THE  INTEGER  VALUE  SHOULD  BE  IN  THE  RANGE  -2147483648  TO  2147483647. 
c 

if (real . It . -2147483648 . OdO . or . real . gt . 2147483647 . OdO ) go  to  28 
c 

integer-int (real) 
return 
c 

28  write(6,101) 

write (6, 209) cha (1 : last) 

209  format ('Warning! ! !  There  is  an  integer  out  of  range.'// 

l'The  allowed  integer  range  in  this  FORTRAN  is  -2147483647  to  21474 
283647 .' ////'Your  number  is  ',a,'.  It  is  out  of  this  range.'//// 

3' The  number  will  be  set  to  the  maximum  or  minimum  according  to  the 
4  sign.'///) 
c 

i f ( sign . gt . 0 . OdO ) then 
integer-2147483647 
else 

integer=-2147483647 

endif 


return 
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subroutine  onedim 
c 

include  'common. me' 
c 

spacing-10 . 0 
step«-l . 0 
sign-1 . 0 
c 

do *10  k-1,10 

x (k) - (k-1) * spacing 
if (sign. gt .0.0) then 
kind (k) -1 
else 

kind (k) -2 
endif 

sign— sign 
10  continue 

c 

call  total_el 
eold-e_total 
c 

20  spacing=spacing+step 

do  30  k-1,10 

x (k) - (k-1) * spacing 
30  continue 

c 

call  total_el 
c 

if  (eold.gt  .e__total)  then 
eold=e_total 
else 

if (step. gt . -1 . Oe-3) go  to  40 
spacing-spacing-step 
step=step*0 . 1 
endif 
go  to  20 
c 

40  spacing-spacing+1 . 0 

c 

do  50  k-1,10 

if (d(k) . eq. 0 . 0) d (k) -spacing/ 3 . 0 
50  continue 

c 

return 


c 


end 
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c 

c 


c 

2010 


SUBROUTINE  OUTPUT 

include  'common. me' 

dum-x (icenter) 
x (icenter) -x (n_points) 
x (n_points) *dum 
dum»y (icenter) 
y (icenter) «y (n_points) 
y  (n_points)  =*dum 
dum*»z (icenter) 
z (icenter) *z (n_points) 
z (n_points) =dum 
k-kind (icenter) 
kind (icenter) =kind(n_points) 
kind (n_points) =k 
k=move (icenter) 
move (icenter) -move (n_points) 
move  (n_points)  =»k 
xshift—x  (icenter) 
yshift=-y (icenter) 
zshift=“-z  (icenter) 

write (2, 2010) title 
format (a) 


write (2,2020) ion (1) , charge (1) , ion (2) , charge (2) , center_ion, 
lcharge (kind (icenter) ) , n_points, n_per_side, all_charge 
2020  format (/'THE  POSITIVE  ION:  ' , a30 , ' CHARGE : ' , f 10 . 2/ 

1 ' THE  NEGATIVE  ION:  ' , a30 , ' CHARGE : ' , f 10 . 2 / 

2 'THE  CENTRAL  ION:  ' , a30, ' CHARGE: ' , f 10 . 2// 

3' THE  NUMBER  OP  IONS:',ilO,'  (',i2,'  PER  SIDE)'// 

4 'THE  NET  CHARGE : ' , f 10 . 4 / ) 


c 

do  10  k»l,n_points 
x (k) =x (k) +xshift 
y (k) =y (k) +yshif t 
z (k) =z (k) +zshift 
10  continue 


write (2,2030) 

2030  format (/'MOVEION: ' /) 

ntotal='n_trials*n_points_ml 

write (2, 2040) n_t rials,  maxt rial , ntotal , iseed,move_total, 

1100 . 0*real (move_total) /real (ntotal ) , -100*pre_poa, e_moveion, 
ie_moveion*27 .2114 

2040  format ('THE  NUMBER  OF  TRIALS  PER  ION:', 

1  t36, ilO, t50, '  (  CUT-OFF  LIMIT:  ',il0,'  )'/ 

2  'THE  TOTAL  NUMBER  OF  TRIALS :', t36, ilO, t50, ' (  SEED:  ', 

3  i6, '  ) ' / ' THE  TOTAL  NUMBER  OF  ACTUAL  MOVES :', t36, ilO/ 

4  'THE  PERCENTAGE  OF  ACTUAL  MOVES : ' , t38,  f 6 . 2,  '  %',t50, 

5  ' (PRESET:  ' , f6.2, '  %) ' // 

6  'THE  TOTAL  ENERGY : ' , f 20 . 4 , '  HY  (',f20.4,'  EV  )'/) 


write (2, 2050) 

2050  format (/'MOVEION  WITH  POLARIZATION;'/) 
ntotal»n_trialsp*n_points_ml 

write (2, 2040) n_trialsp, maxtrialp, ntotal, iseed,move_totalp, 
1100 . 0*real (move_totalp) /real (ntotal) , -100*pre_poa, e_moveionp, 
2e_moveionp*27 .2114 
c 

n_trial3t*n_trials+n_trialsp 
maxtrialt-maxtrial+maxtrialp 
move  totalt-move_total+move_totalp  __ 
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write  (2,2060) 

2060  format (/'ALL  TOGETHER:'/) 

ntotal-n_trialst*n_points_ml 

write (2, 2040) n_trialst, maxt rial t,  ntotal, iseed, move_totalt, 

1100 . 0*real (move_totalt) /real (ntotal) , -100*pre_poa, e_moveionp, 
2e_moveionp*27 . 2114 
c 

call  count (center_ion,  last) 
write (2,2070) center_ion (1 :last) 

2070  format  (/'THE  NEAREST  NEIGHBORS  OF  THE  CENTRAL  ION  —  ',a,':'// 

1  tl2,'X',t21,'Y',t30,'Z', 

2  t37, 'DISTANCE  TO  CENTER' ,  t60, 'AVERAGE' , t72, ' DEVIATION' /) 
c 

weight-1 .  0 

xdis=x (myf ront) -x (icenter) 
ydis=y (myfront) -y (icenter) 
zdis=z (myfront) -z (icenter) 

xtemp (myfront) -sqrt (xdis*xdis+ydis*ydis+zdis*zdis) 
xdis-x  (myright)  -x  (icenter) 
ydis-y (myright) -y (icenter) 
zdis=z (myright) -z (icenter) 

xtemp (myright) -sqrt (xdis*xdis+ydis*ydis+zdis*zdis) 
xdis=x (myabove) -x (icenter) 
ydis-y (myabove) -y (icenter) 
zdis=z (myabove) -z (icenter) 

xtemp (myabove) -sqrt (xdis*xdis+ydis*ydis+zdis*zdis) 
averagel- (xtemp (myfront) +xtemp (myright) +xtemp (myabove) ) /3 . 0 
deviation-xtemp  (myfront)  *xtemp  (myfront) 

1  +xtemp (myright) *xtemp (myright) 

2  +xtemp (myabove) *xtemp (myabove) 
deviation=deviation/3 . 0 

deviation=sqrt (deviation-averagel*averagel) 
c 

write (2,2080) x (myfront) , y (myfront) , z (myfront) , xtemp (myfront) 
2080  format ( ' FRONT'  ,t8,3(f7.3,2x)  ,t43,f6.3) 

write (2, 2090) x (myright) , y (myright) , z (myright)  ,  xtemp (myright) , 

1  averagel, deviation 

2090  format ('RIGHT'  ,t8,3(f7.3,2x),t43,f6.3,t60,f6.3,t73,f8.6) 

write (2, 2100) x (myabove) , y (myabove) , z (myabove) , xtemp (myabove) 
2100  format ( ' ABOVE' ,t8,3(f7.3,2x),t43,f6.3/) 
c 

if (myback. le. 0) go  to  20 
weight=0.5 

xdis=x (myback) -x (icenter) 
ydis-y (myback) -y (icenter) 
zdis=z (myback) -z (icenter) 

xtemp (myback) -sqrt (xdis*xdis+ydis*ydis+zdis*zdis) 
xdis=x (myleft) -x (icenter) 
ydis-y (myleft) -y (icenter) 
zdis=z (myleft) -z (icenter) 

xtemp (myleft) =sqrt (xdis*xdis+ydis*ydis+zdis*zdis) 
xdis=x (mybelow) -x (icenter) 
ydis=y (mybelow) -y (icenter) 
zdis=z (mybelow) -z (icenter) 

xtemp (mybelow) =sqrt (xdis*xdis+ydis*ydis+zdis*zdis) 
average2* (xtemp (myback) +xtemp (myleft) +xtemp (mybelow) ) /3 . 0 
deviation=xtemp (myback) *xtemp (myback) 

1  +xtemp (myleft) *xtemp (myleft) 

2  +xtemp (mybelow) *xtemp (mybelow) 
deviation-deviation/3 . 0 

deviation-sqrt (deviation-average2*average2) 
c 

write (2, 2110) x (myback) , y (myback) , z (myback) , xtemp (myback) 

2110  format ('BACK'  ,t 8, 3 (f7 . 3, 2x) , t43, f 6 . 3) 
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2120 

2130 

c 

20 

2140 

c 

c 

2150 

c 

2160 

80 

c 

c 


write  <2,2120)x(myleft) ,y (myleft) , z (myleft) , xtemp (myleft) , 

1  average2, deviation 

format ( ' LEFT' , 1 8 , 3  (f 7 . 3, 2x) ,t43,f6.3,t60, f6.3,t73, f8.6) 
write (2, 2130) x (mybelow) ,y (mybelow) , z (mybelow) , xtemp (mybelow) 
format ('BELOW' ,t8, 3 (f 7.3, 2x) ,t43,  f6.3/) 

spacing- (averagel+average2) ‘weight 

write (2,2140) spacing, spacing* 0 . 52917 

format {'THE  AVERAGE  NEAREST-NEIGHBOR  SPACING: ' , f 9 . 4, 

1  '  BOHRS  (' , f 9. 4, '  ANGSTROMS  )') 

if (ipc.eq.0) return 

write (2, 2150) 

format (//'THE  COORDINATES  OF  THE  IONS:'// 

1'  ORDER' , til, ' ION' ,t24, 'CHARGE' , 

2t39,  'X'  ,t50, 'Y' ,t61,'Z' ,t73, 'MOVE' /) 

do  80  k=l,n_points 

if (kind(k) .gt.l0)then 

write (2, 2160) k, ion (kind (k) -10) , charge (kind (k) -10) +charge (5) , 
1  x (k) ,y (k) ,  z (k) ,move (k) 

format (i6, til, a6, t22, f 8. 4, t33, 3 (fl0.4,lx),t71,i6) 
else 

write (2, 2160) k, ion (kind (k) ) ,  charge (kind(k) ) , 

1  x (k) ,y (k) , z (k) ,move (k) 

endif 
continue 

return 

end 
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c 

c 


function  rani (dum) 

include  'common. me' 

ixl-mod(ial*ixl+icl,ml) 
ix2~mod(ia2*ix2+ic2,m2) 
ix3~mod(ia3*ix3+ic3,m3) 
k»l+97*ix3*rro3 
ranl“randoml (k) 

randoml (k) - (real (ixl) +real (ix2) *rm2) *rmll 
return 


c 


end 
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c 

c 


c 


function  ran2 (dum) 

include  'common. me' 

ixl-mod (ial*ixl+icl,ml) 
ix2-mod(ia2*ix2+ic2,m2> 
ix3”mod(ia3*ix3+ic3,m3) 
k«l+97*ix3*rm3 
ran2»random2 (k) 

random2 (k)-(real (ixl)+real (ix2) *rm2) *rml2+negone 
return 


c 

end 
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c 

c 


c 

1010 

c 

10 

6010 

c 

20 

1020 


6020 


c 

1030 

6030 


6040 

c 

1040 


SUBROUTINE  READIN 
include  'common. me' 

character* 80  anycha,alphaunit,  bunit, cha, chal,  cha2, cunit, dunit, 
lempty, rhounit 

parameter (anycha=' *' ,empty='  ') 
parameter (dfactor»l . 0/0 . 529177) 
parameter (df  actor3=df actor *df actor *df act or) 
parameter (dfactor6»dfactor3*df act or 3) 
parameter (efactor»l .0/27 . 2114) 

read(l, 1010, end“10) title 
format (///a/) 
go  to  20 

write (6, 6010) 

format (///' Sorry .  The  input  file  does  not  exist.'///) 
stop 

read(l, 1020) pre_poa, accuracy 

format (//'THE  PRESET  PERCENTAGE  OF  ACCEPTANCE :', e44 . 0/ 

1  'THE  ACCURACY  OF  THE  POSITIONS :', e50 . 0/) 

if (pre_poa . le. 0 . 0) then 
write (6, 6020) pre_poa 

format (III' Sorry .  The  preset  percentage  of  acceptance  is:', 

1  t50, flO .2, '%.'//' It  must  be  greater  than  zero.'// 

2  'Stop.'///) 
stop 

endif 

pre_poa=-0 . 01*-pre_poa 

if (accuracy . It . 0 .  0) accuracy=-accuracy 

if (accuracy .eq. 0.0) accuracy=l . 0e-02 

read(l, 1030) dum, center_ion 

format (//'THE  NUMBER  OF  IONS  PER  SIDE : ' , e52 . 0, 
l/'PRI’d  OUT  ALL  COORDINATES?' ,a54/) 
n_pei_ jide-dum 
if (n_per_side.gt .nmax) then 
write (6, 6030) nmax, n_per_side 

format (///' Sorry .  The  maximum  number  of  ions  per  side  is', 

1  t50, i3, ' . ' /' You  specified  number  is' , t50, i3, ' . ' // 

2  'Stop.  Increase  that  number  in  the  file  common. me'/ 

3  'and  recompile  the  program.'///) 
stop 

endif 

call  cutnull (center_ion) 

if (center_ion (1:1) . eq. '  Y'  . or . center_ion (1:1) . eq. ' y' ) ipc=l 

if (n_per_side . le . 0) then 
write  (6,  6040) 
format (/// 

1  'Sorry.  The  number  of  points  must  be  greater  than  zero.'///) 
stop 
endif 

readd,  1040)bunit,  spacing 

format (//'THE  INITIAL  NEAREST  NEIGHBOR  SPACING  {' , t39, alO, ' )  :' 
1  e30 . 0///) 

if (spacing.lt .0.0) spacing=-spacing 

if (spacing. eq. 0 . 0) then 
ionedim-1 
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go  to  30 
endif 
c 

call  cutnull (bunit) 

call  caaechange (bunit,  idum) 

if (bunit (1:1) .eq. 'A' ) spacing=spacing*df actor 
c 

30  read(l, 1050) cha 
1050  format (a) 

if (cha (1:7) .eq. ' LATTICE' ) then 
alphaunit^cha (61:68) 
call  cutnull (alphaunit) 
call  casechange (alphaunit, idum) 
go  to  30 
endif 

if(cha.ne.'  ' ) then 
n_k i nds »n_k i nds + 1 

call  search (cha, 1, 80, anycha, ilstcha, idum) 
call  search (cha, ilstcha, 80, empty, iblank, idum) 
ion (n_kinds) =cha (ilstcha : iblank-1) 
call  search (cha, iblank, 80, anycha, ilstcha, idum) 
call  search (cha, ilstcha, 80, empty,  iblank, idum) 
chal-cha (ilstcha: iblank-1) 
call  number (chal, 0,dum, idum) 
charge (n_kinds) *dum 

call  search (cha, iblank, 80, anycha, ilstcha, idum) 
call  search (cha, ilstcha, 80, empty, iblank, idum) 
chal»cha (ilstcha : iblank-1) 
call  number (chal, 0, dum, idum) 
alpha (n_kinds) =dum 
call  casechange ( ion (n_kinds ) , idum) 
go  to  30 
endif 
c 

if (charge (1 ) . eq. 0 . 0 . or . charge (2) .eq. 0 . 0) then 
write  (6,  6050) 

6050  format (///'Sorry.  One  charge  is  specified  as  0  (zero).' 

1  //'This  is  not  allowed  in  this  program.'///) 

stop 
endif 
c 

read(l, 1060) center_ion 
1060  format (//'THE  CENTRAL  ION:',a64/) 
call  cutnull (center_ion) 
call  casechange (center_ion, idum) 
if (center_ion .eq. ion (1 ) ) then 
kind_of_center*l 

elseif (center_ion . eq. ion (2) ) then 
kind_of_center»2 
else 

write (6, 6060) 

6060  format (///' Sorry .  The  central  ion  is  not  correctly  specified. 
1  III) 

stop 
endif 
c 

read (1,1 070) dum 

1070  format (//'NUMBER  OF  DEFECT  IONS : ' , e58 . 0// ) 
n_de f e c t s «dum 
if (n_defects .gt .2) then 
write (6, 6070) 

6070  format (///' Sorry .  Too  many  defect  ions.'// 

1  'The  maximum  number  is  2 .'///) 


stop 


readin . £ 


Thu  Apr  18  15:26:11  1991 


3 


endif 

if (n_defects.ne.O)then 
do  40  k-1, n_defecta 
n_kinds-n_kinda+l 
read(l, 1050) cha 
if(cha.eq.'  ')then 

write (6, 6090) n_defects 

6090  format (///' Sorry .  The  number  of  defect  ions  is', 

1  i2,'.'// 

2  'But  there  is  no  entry  for  the  defect  ion(s). 

3  //'Stop.'///) 
stop 

endif 

call  search (cha,  1, 80,  anycha,  ilstcha, idum) 

call  search (cha, ilstcha, 80, empty, iblank, idum) 

ion (n_kinds) -cha (ilstcha :iblank-l) 

call  casechange (ion (n_kinds) ,  idum) 

call  search (cha, iblank, 80, anycha, ilstcha, idum) 

call  search (cha, ilstcha, 80, empty, iblank, idum) 

chal-cha (ilstcha : iblank-1 ) 

call  number (chal, 0, dum, idum) 

charge (n_kind3) -dum 

call  search (cha,  iblank, 80, anycha, ilstcha, idum) 
call  search (cha, ilstcha, 80, empty, iblank, idum) 
chal-cha (ilstcha: iblank-1) 
call  number (chal, 0, dum, idum) 
alpha (n_kinds) -dum 

call  search (cha, iblank, 80, anycha, ilstcha, idum) 
call  search (cha, ilstcha, 80, empty, iblank, idum) 
defect_site (k)-cha (ilstcha:iblank-l) 
call  cutnull (defect_site (k) ) 
call  casechange (defect_site (k) , idum) 

40  continue 

endif 
c 

readd ,  1080)bunit,  rhounit,  cunit,  dunit 
1030  format (//////' B:', all, ' RHO: ' , al2 , 'C: ' , a23, ' D: ' , a24///) 
c 

call  cutnull (bunit) 
call  cutnull (rhounit) 
call  cutnull (cunit) 
call  cutnull (dunit) 
call  casechange (bunit,  idum) 
call  casechange (rhounit,  idum) 
call  casechange (cunit, ic) 
call  casechange (dunit, idum) 
c 

n_lines-0 

c 

50  readd,  1050)  cha 

if ( cha. eq. empty) go  to  140 

n_lines-n_lines+l 

call  casechange (cha, idum) 

call  search (cha, 1, 80, anycha, ilstcha, idum) 

60  call  search (cha, ilstcha, 80, empty, iblank, idum) 

call  search (cha, iblank, 80, anycha, ilstcha, idum) 
if (ilstcha. eq. 80)go  to  50 
do  70  1-1,10 

if (cha (ilstcha : ilstcha) . eq. chn (1) ) go  to  80 
70  continue 

go  to  60 
80  n-ilstcha 

if (n.eq. 80) then 

write (6, 6110) norn (n_lines) 


readin . t 


Thu  Apr  18  15:26:11  1991 


4 


6110  format (///' Sorry.  Error  in  short-range  potentials:  ', 

1  a,'  line.'// 

2  'Each  line  should  have  four  numbers.'///) 
stop 

endif 
chal-' <>' 

call  search (cha, 1, iblank, chal, ihead, itail) 
if (ihead. It . iblank) go  to  90 
write (6, 6100) norn (n_lines) 

6100  format (///' Sorry .  Error  in  short-range  potentials:  ',a,'  line.'/ 
1  //'There  must  be  a  "<>"  between  the  ion  names.'///) 

stop 

90  chal-cha (1 : ihead-1) 
call  cutnull (chal) 
do  100  i«l,n_kinds 

if (chal .eq. ion (i) ) go  to  110 
100  continue 

write (6, 6120) norn (n_lines) , chal 

6120  format (///' Sorry.  Error  in  short-range  potentials:  ',a,'  line.'/ 
1  //'An  ion  is  not  -specif ied: ' /a///) 

stop 

110  cha2=cha (ihead+2 :n-l) 
call  cutnull (cha2) 
do  120  j-l,n_kinds 

if (cha2 .eq. ion ( j) ) go  to  130 
120  continue 

write (6, 6110) norn (n_lines) , cha2 
stop 

130  a (ichoose (i, j) ) -charge (i) ‘charge ( j) 

call  search (cha, n, 80, empty, iblank,  idum) 
chal-cha (n: iblank-1) 
call  number (chal, 0,dum, idum) 
b  (ichoose  (i,  j)  )  -abs  (dum) 

call  search (cha, iblank, 80, anycha, ilstcha, idum) 
if (ilstcha . eq. 80) then 

write (6,  6110) norn (n_lines) 
stop 
endif 

call  search (cha, ilstcha, 80, empty,  iblank, idum) 
chal-cha (ilstcha: iblank-1) 
call  number (chal, 0, dum, idum) 
rho  (ichoose  (i,  j)  )  -abs  (dum) 

call  search (cha, iblank,  80, anycha,  ilstcha, idum) 
if (ilstcha. eq. 80) then 

write (6, 6110) norn (n_lines) 
stop 
endif 

call  search (cha, ilstcha, 80, empty,  iblank, idum) 
chal-cha (ilstcha : iblank-1 ) 
call  number (chal, 0, dum, idum) 
c  (ichoose  (i,  j) )  -abs  (dum) 

call  search (cha, iblank,  80, anycha, ilstcha, idum) 
if  (ilstcha . eq. 80) then 

write (6, 6110) norn (n_lines) 
stop 
endif 

call  search (cha, ilstcha, 80, empty, iblank, idum) 
chal-cha (ilstcha : iblank-1 ) 
call  number (chal, 0, dum, idum) 
d(ichoose (i, j) ) -abs (dum) 
go  to  50 
c 

140  do  150  k-1,10 

if (a (k) .eq. 0 . 0)go  to  150 

63 
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if (alphaunit (1 : 1) .eq. ' A' ) alpha (k) -alpha (k) *dfactor3 
if (bunit (1:1) .eq.'E' )b(k)-b(k) *ef actor 
if (bunit <1 : 1) .eq. 'R' ) b (k) -0 . 5*b (k) 
if (rho(k) . eq. 0 . 0) rho (k) -1 . 0 

if (rhounit  (1:1) .eq.'A' ) rho (k) -dfactor*rho (k) 
rho  (k)  —1 . 0/ rho  (k) 

if (cunit (1:1) .eq.'E'  )c(k)-c(k) *ef actor 
if (cunit (ic:ic) .eq.'A' ) c(k)-c(k) *dfactor6 
if (d(k) . eq. 0 . 0) d(k) -spacing/ 3 . 0 
if (dunit (1:1) .eq.'A' )d(k)-d(k) *df actor 
150  continue 
c 

return 
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'  SUBROUTINE  SEARCH  (CHA,  ISTART,  IFINISH,  SCHA,  IHEAD,  ITAIIi) 

character*80  cha, scha, temp 

ilst*0 

last*0 

do  10  k-1,80 

if <scha(k:k) .ne.'  ' ) then 
ilst«k 
go  to  20 
endif 
continue 
ilst»80 

do  30  k«ilst,80 

if (scha(k:k) .eq.'  ' j then 
last*k-l 
go  to  40 
endif 
continue 
last~80 

temp-scha (ilst : last) 

numcha-last-ilst+1 
if (temp, eq.'  ')numcha«0 

do  50  k*istart,  if inish-numcha 
if (temp. eq. '  *' ) then 

if  (cha(k-.k)  .ne.'  ')then 
ihead*k 
itail-k 
return 
endif 
go  to  50 
endif 

kpnumcha»k+numcha 

if^^haikukpnlUncha,  ‘ec*-  temP>  then 
inead»k 

itail«kpnumcha 

return 

endif 

continue 

ihead«ifinish 

itail»ifinj_3h 

return 
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SUBROUTINE  SHUFFLE 
C 

include  'common. me' 


c 

do  10  k-1, n_points_ml 
xtemp (k) -rani (dum) 

10  continue 
c 

do  30  i-1, n_points_m2 
do  20  j-i+1, n_points_ml 

if (xtemp ( j) .  gt . xtemp (i) ) go  to  20 
dum-xtemp (i) 
xtemp (i) -xtemp ( j) 
xtemp ( j) -dum 
k=iorder (i) 
iorder (i) -iorder ( j) 
iorder ( j) -k 
20  continue 

30  continue 
c 

return 


c 


end 
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SUBROUTINE  TOTAL_E 
include  ' common. me' 
e_total-0 . 0 

r* 

do  20  ii-1, njpoints 

do  10  j j-ii+1, n_points 
dx«x (ii) -x { j j) 

dy-y(ii)-y(jj) 

dz**z  (ii)  -z  ( j  j) 
sr2»dx*dx+dy*dy+dz*dz 
if (sr2 . It . 1 . Oe+2) then 
kk»sr2* 10000+0 . 5 
sr»sroot (kk) 

elseif (sr2 . It . 1 . Oe+4) then 
kk«sr2*100+0. 5 
sr=10 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+6) then 
kk«sr2+0.5 
sr=100 . 0*sroot (kk) 
elseif (sr2 . It . 1 . 0e+8 ) then 
kk*sr2*l . 0e-2+0 . 5 
sr-1000 . 0*sroot (kk) 
else 

write (2, 2010) ii, j j,x (ii) , x ( j j) , dx, y (ii) ,y(  j  j)  ,dy, 

1  z (ii) , z ( j j) ,dz,sr2 

2010  format (///' Sorry .  SROOT  is  not  large  enough  for  TOTAL_E.'// 


i-' , i4 

j 

=', 

i4/ 

x(i)-' 

,  f20 

.8, 

'  x(ji*' 

,  f20 

8, ' 

dx=' 

,  f20 

8/ 

y  (i)  **' 

,  f20 

.8, 

,  f20 

8,' 

dy=' 

,  f 20 

8/ 

z  (i) 

,  f20 

.8, 

'  z(j)=' 

,  f20 

8,' 

dz=' 

,  f20 

8/ 

sr2='. 

f  20 . 

8) 

stop 

endif 

if(sr.gt. 100.0) then 
e_total=e_total 

1  +a (ichoose (kind(ii) ,  kind( j j) ))/sr 

else 

kk=sr*10000 

e_total=e_total 

1  +potential (kk, ichoose (kind(ii) , kind( j j) ) ) 

endif 

10  continue 

20  continue 
c 

return 


c 

end 


bl 
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c 

c 

c 


20 

30 

c 


SUBROUTINE  TOTAL_El 

include  'common. me' 

e_total-0 . 0 

do  30  ii-1,10 
do  20  jj-ii+1,10 
C5-0.0 

if (kind(ii) .gt.l0)then 
kind_ii=kind(ii) -10 
if (kind( j j) .gt . 10) then 
kind_j j-kind( j j) -10 

c5»a (ichoose (5, kind_ii) ) +a (ichoose (5, kind_j j) ) +a (15) 
else 

kind_ j  j»kind ( j  j ) 
c5-a (ichoose (5, kind_j j) ) 
endif 
go  to  10 
else 

kind_ii=kind (ii) 
endif 

if (kind(jj) .gt.l0)then 
kind_j j=kind( j j) -10 
c5=*a  (ichoose  (5,  kind_ii) ) 
else 

kind_ j  j=kind ( j  j ) 
endif 

dx«x (ii) -x ( j j) 
distance=sqrt (dx*dx) 
if (distance. gt. 100. 0) then 

e_total*e_total+a (ichoose (kind_ii, kind_j j) ) /distance 
else 

kk»di stance* 10000 

e_total=e_total+potential <kk,  ichoose (kind_ii, kind_j j ) ) 
endif 

if (c5 . ne . 0 . 0) e_total=e_total+c5/distance 
continue 
continue 

return 


c 


end 


total  «c . f 


Thu  Apr  18  15:26:12  1991 


SUBROUTINE  TOTAL  EC 


include  ' common. me' 


total* 


do  30  ii-l,n_points 

do  20  j j-ii+1, n_points 
C5-0.0 

if (kind (ii) .gt. 10) then 
kind_ii-kind(ii)  -10 
if (kind( j j) .gt.  10) then 
kind_j j»kind( j j) -10 

c5=*a  (ichoose  (5,  kind_ii)  )  +a  (ichoose  (5,  kind_j  j)  )  +a  (15) 
else 

kind_j  j»kind ( j  j ) 
c5-a (ichoose (5,  kind_j j) ) 
endif 
go  to  10 
else 

kind_ii-kind(ii) 

endif 

if (kind( j j) .gt . 10)  then 
kind_j j*kind( j j)  -10 
c5**a  (ichoose  (5,  kind_ii) ) 
else 

kind_ j  j=kind ( j  j ) 
endif 

dx**x  (ii)  -x  ( j  j) 
dy=y  (ii)  -y  ( j  j) 
dz-z (ii) -z  ( j j) 
sr2-dx*dx+dy*dy+dz*dz 
if  (sr2 . It . 1 . Oe+2) then 
kk“sr2*10000+0 . 5 
sr»sroot (kk) 

elseif(sr2.1t.l. Oe+4 ) then 
kk«sr2*100+0.5 
sr»10 . 0*s root (kk) 
el seif (sr2 . It . 1 . Oe+6) then 
kk»3r2+0 . 5 
sr**100 . 0*sroot  (kk) 
el seif (sr2 . It . 1 . 0e+8) then 
kk»sr2*l . 0e-2+0 . 5 
sr=1000 . 0*sroot (kk) 
else 

write (2, 2010)ii, jj,x(ii) ,x (jj) ,dx,y(ii) , y { j  j) ,dy, 

1  z (ii) , z ( j j) , dz, sr2 

format (///' Sorry .  SROOT  is  not  large  enough  for  TOTAL_EC.'// 


i«' , i4 

j 

-  t 

9 

i4  / 

x  ( i )  — ' 

,  f 20 

.8, 

'  x(j)=' 

,  f  20 

8,' 

dx=' 

,  f20 

8/ 

y (i) 

,  f  20 

.8, 

'  y ( j)-' 

,  f  20 

8,' 

dy=' 

,  f  20 

8/ 

z  (i)  **' 

,  f20 

•  8, 

'  z<j)=' 

,  f  20 

8,' 

dz=' 

,  f20 

8/ 

sr2*' , 

f  20 . 

8) 

stop 

endif 

if(sr.gt. 100.0) then 
e_t  ot a 1 -e_t  ot  a 1 

+a  (ichoose (kind_ii, kind_j j) ) /sr 

else 

kk-sr*10000 

e_total»e_total 

+potential (kk, ichoose (kind_ii, kind_j  j) ) 

endif 

if (c5 . ne . 0 . 0) e  total-e  total+c5/sr 
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20 

30 

c 


c 


continue 

continue 

return 

end 


10 
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SUBROUTINE  TOTAL_EP 
C 

include  ' common. me' 
c 

call  getp 
c 

e_total»0 . 0 
c 

do  20  ii=l, n_points 

do  10  j j«ii+l,n_points 
dx-x (ii) -x  ( j j) 
dy-y (ii) -y  ( j j) 
dz«z (ii) -z ( j j) 
sr2-dx*dx+dy*dy+dz*dz 
if (sr2 . It . 1 . Oe+2) then 
kk“sr2* 10000+0 . 5 
sr*sroot (kk) 

el seif  (sr2 . It . 1 . Oe+4 ) then 
kk=sr2* 100+0 . 5 
sr«10 . 0*sroot (kk) 
el seif (sr2.1t.l. Oe+6) then 
kk*sr2+0.5 
sr«100 . 0*sroot (kk) 
el seif (sr2 . It • 1 . Oe+8) then 
kk-sr2*l . Oe-2+O . 5 
sr-1000 . 0*sroot (kk) 
else 

write (2,20l0)ii, j j,x(ii) ,x( j j) ,dx,y (ii)  ,y ( j j)  ,dy, 

1  z(ii) ,z(jj) ,dz,sr2 

2010  format (///'Sorry.  SROOT  is  not  large  enough  for  TOTAL_EP. ' // 

'i-',i4,'  j-',i4/ 

' x  (i) , f20 . 8 , '  x ( j) , f20 . 8, '  dx-',f20.8/ 

' y  (i ) =' , f 20 . 8 , '  y  ( j) , f20 . 8, '  dy=',f20.8/ 

4  ' z  (i ) =' , f 20 . 8 , '  z ( j) =' , f20 . 8,  '  dz=',f20.8/ 

5  ' sr2=' , f20 . 8) 
stop 

endif 

sr3*sr*sr2 
uvx-dx/sr 
uvy=dy / sr 
uvz*dz/sr 

pi_dot_p j=p ( 1 , ii ) *p(l, j j) +p (2, ii) *o (2, j j) +p (3, ii) *p(3, j j) 
pi_dot_ri  j=p  (1,  ii)  *uvx+p  (2,  ii)  *uvy-rp  (3,  ii)  *uvz 
pj_dot_ri  j*pd,  j j) *uvx+p(2,  j  j)  *uvy+p(3,  jj)  *uvz 
w=*  (pi_dot__pj-3 . 0*pi_dot_ri  j*p  j_dot_ri  j)  /sr3 
if (sr .gt . 100.0) then 
e_total«e_total 

1  +a (ichoose (kind(ii) , kind ( j j) ) ) /sr+w 

else 

kk-sr*10000 

e_total-e_total 

1  +potential (kk, ichoose  (kind (ii) , kind( j j) ) ) +w 

endif 

10  continue 

20  continue 
c 

return 


c 

end 
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c 

c 

c 


SUBROUTINE  TOTAL_EPC 
include  'common. me' 
call  getp 
e  total-0.0 


do  30  ii-l,n_points 

do  20  j j-ii+1, n_points 
C5-0.0 

if  (kind(ii) .gt.10) then 
kind_ii-kind(ii) -10 
if (kind( j j) .gt . 10) then 
kind_j j=kind( j j) -10 

c5=a (ichoose (5, kind_ii) ) +a (ichoose (5, kind_j j) ) +a (15) 
else 

kind_ j  j=kind ( j  j ) 
c5=a (ichoose (5, kind_j j) ) 
endif 
go  to  10 
else 

kind_ii*kind (ii) 
endif 

if (kind(jj) .gt.l0)then 
kind_ j j-kind ( j  j ) -1 0 
c5-a (ichoose (5,  kind_ii) ) 
else 

kind_  j  j-kind  ( j  j ) 
endif 

10  dx-x (ii) -x  ( j j) 

dy=y (ii) -y  ( j j) 
dz=z (ii) -z  ( j j) 
sr2=dx*dx+dy*dy+dz*dz 
if (sr2 . It . 1 . 0e+2) then 
kk=sr2* 100 00+0 . 5 
sr=sroot (kk) 

elseif (sr2 . It . 1 . Oe+4) then 
kk-3r2*100+0 . 5 
sr-10 . 0*sroot (kk) 
elseif (sr2 . It . 1 . 0e+6) then 
kk=sr2+0 . 5 
sr=100 . 0*sroot (kk) 
elseif (sr2 . It . 1 . Oe+8) then 
kk»sr2*l . 0e-2+0 . 5 
sr-1000 . 0*sroot (kk) 
else 

write (2, 2010) ii, j j,x (ii) ,x( j j) ,dx,y (ii) ,y ( j j) ,dy, 

1  z (ii) , z ( j j) , dz, sr2 

2010  format(/// 

1  'Sorry.  SROOT  is  not  large  enough  for  TOTAL_EPC . ' / / 


i-' , i4 

» '  j 

—  t 

t 

i4/ 

x (i) -' 

,  f  20 

.8, 

'  X 

(j)=' 

,  f20 

8,' 

dx=' 

,  f 20 

8/ 

y (i)-' 

,  f  20 

.8, 

'  y 

(j)-' 

,  f20 

8,' 

dy-' 

,  f  20 

8/ 

z(i)-' 

,  f  20 

.8, 

'  z 

( j)-' 

,  f  20 

8,' 

dz-' 

,  f20 

8/ 

sr2-' , 

f  20 . 

8) 

stop 

endif 

sr3-sr*sr2 

uvx-dx/sr 

uvy-dy/sr 

uvz-dz/sr 

pi_dot_pj-p(l,ii) *p(l, jj)+p(2,ii) *p(2, j j)+p(3,ii) *p(3, j j) 
pi_dot_ri j-p (1, ii) *uvx+p (2, ii) *uvy+p (3, ii) *uvz 
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p  j_dot_ri  j-p  (1, j j) *uvx+p<2, j j) *uvy+p(3, j j)*uvz 
w- (pi_dotjpj-3 . O*pi_dot_ri j*p j_dot_ri j) /sr3 
if (sr.gt. 100.0) then 
e_total»e_total 

1  +a (ichoose <kind_ii,  kind_j j) ) /sr+w 

else 

kk-sr*10000 

e_total«e_total 

1  +potential<kk, ichoose (kind_ii,kind_jj) ) 

endif 

if (cS.ne. 0. 0) e_total«e_total+c5/sr 
20  continue 

30  continue 
c 

return 


APPENDIX  B 

LISTING  OF  THE  MAIN  PROGRAM  LOPAS  CODE 
UNI-PROCESSOR  VERSION 

A.  B.  Kunz ,  Author 


deserve  r:barry 
lopas 

FriMar  8  13:08:471991 
Iw  /  TCD  LaserWriter  II  NT 

lw  deserver : bar ry  Job:  lopas  Date:  Fri  Mar  8  13:08:47  1991 

lw  deserver :barry  Job:  lopas  Date:  Fri  Mar  8  13:08:47  1991 

lw  deserver :barry  Job:  lopas  Date:  Fri  Mar  8  13:08:47  1991 


lw  deserver: barry  Job:  lopas  Date:  Fri  Mar  8  13:08:47  1991 


o  o  o  o n  o  on  non  non 


C  This  is  an  implementation 

C  of  local  orbitals  procedures  of 
C  Adams,  Gilbert  and  Kunz  implemented 
C  for  cluster  building  blocks  and 
C  a  gaussian  basis  set 
C  part  of  the  MEGAMOL  sequence 

C  Molecules  for  the  90' s 
C  author  is  A  B  Kunz 
C  Michigan  Technological  University 
C  College  of  Engineering 
C  Fortran  77 
C  written  1989-91 

C  all  rights  reserved  by  the  author 

C 

★  ★★★★★★★★*★★★★★*★★**★★★★*★★★★★★★■**★★★★★**★★*★•*★★**★*★★**»*★**★**** 
Program  lopas 

implicit  real*8 (a-h, o-z ) 
dimension  nenv (20) , id (20, 200) , 
lxof (20,200) ,yof (20,200) , zof (20,  200)  , 

2a (20, 200) ,b (20, 200) , c (20, 200) 
common/angle/angl (73)  ,  cangl (73)  ,  sangl (73) 
real*8  norm 

1  format (i4) 

2  format ('  THIS  IS  A  GAUSSIAN  BASIS  SET  LOPAS  CALCULATION  ' ,/, 

1'  USING  THE  MULTI  CENTER  METHOD  OF  A  B  KUNZ  ',/, 

2'  FOLLOWING  THE  PROCEDURE  OF  ADAMS -GILBERT-KUNZ  ' ) 

3  format (lx,'  nbb  -  ',i4) 

4  format (i4) 

5  format (i4 , 6x, 6f 10 . 4 ) 

6  format (lx,'  nenv(i)  -  ',i4) 

7  format(lx,'  id  -  ',i4,'  xof  -  ',fl0.4,'  yof  *  ',fl0.4, 

1'  zof  -  ' , f 10 . 4 , / , '  angle  1  -  ',fl0.4,'  angle  2  -  ',flC.4, 

2'  angle  3  -  ' ,fl0.4) 

19  format  ('  moments  run  ') 

18  format  ('  pot  run  ') 

open (unit-61,  file-' mol5f.dat' , form-' formatted' ) 
open (unit-60,  file-'mol5e. dat' ,  form-' formatted' ) 
open (unit-14, f ile-' moll 4 . dat' , form-' formatted'  ) 

★  ★★★★★★★★★★★★★★★★★★■**************w***,***'******»'***,****irirwTtir***Tr*** 

define  local  orbitals  problem 

read (14, 1) nbb 
write (60,2) 
write (60, 3) nbb 
print  2 
print  3, nbb 

if (nbb. It . 1 .or . nbb. gt . 20) stop  '  wrong  number  of  building  blocks  ' 
do  20  i-1, nbb 
read (14 , 4) nenv (i) 

if  (nenv(i) .gt . 200) stop  '  too  many  in  environment  ' 
do  20  j-l,nenv  (i) 

read ( 14, 5) id (i, j) , xof (i, j) , yof (i,  j) , zof (i, j) , a (i,  j ) , b (i, j ) , c (i, j) 

20  continue  _/ 


on  o  no  n  n  n  n  n  n  n  o  o  o  o  o  o  o  o  o  n  n 


do  21  i-l,nbb 
write (60, 6) nenv (i) 
print  6,nenv(i) 
do  21  j-1, nenv(i) 

write  (60, 7)  id(i,  j)  ,xof  (i,  j) ,  yof  (i,  j) ,  zof  (i,  j),a(i,j),b(i,  j),c(i,j) 
print  7, id(i, j) , xof (i, j) ,  yof (i, j) , zof (i,j),a(i,  j),b(i,j),c(i,j) 
close (unit-60) 
close (unit-14) 


set  up  angular  table  here 
do  101  i-1,73 

angl (i) -float  (i-1) *0.087266463 
cangl (i)-cos (angl (i) ) 

111  sangl (i) -sin (angl (i) ) 

lopas  set  up  data  done  now 

Do  local  orbital  building  blocks  in  free  space  now 

ilop-0 

do  30  i*l,nbb 
»«-***this  is  a  par-do 
iread-0 

call  lister  (i, ilop) 

call  poly (i, ilop, iread, nbfs, non) 

call  uhf(i,ilop) 

30  continue 

free  space  estimates  of  building  blocks  are 
evaluated  here 

get  multipole  moments  and  begin  lopas  rotations 

★  ★★★★★★★★★★★♦★★★★★★★★★♦★************TrTrirw**********'*ir****»-r******** 

do  9999  ilps-1,4 
ilop-ilps 

evaluate  moments  of  each  lopas  block  here 
evaluate  detailed  potentials  as  well 
do  40  i-l,nbb 
”'***this  is  a  par-do 
40  call  moments (nbfs, i, ilps ) 
print  19 

moments  and  vOO  potential  formed  for  each  block 
form  potential  of  environment  of  each  building  block 
do  50  i-l,nbb 
C”***this  is  a  par-do 

call  pot (nbfs, ilps, nenv, xof, yof,zof,a,b,c,i,id) 

print  18 

call  uhf(i,ilop) 

50  continue 
9999  continue 

close (unit-61) 

stop  'lopas  complete' 

end 

Subroutine  moments (nbfs, ibb, ilpss) 
c  calculates  VOO  potential  for  this  building  block 
c  calculates  moments  as  well 

c  uses  spherical  coordinates  and  3-d  numerical  quadrature 
c  authored  by  A  B  Kunz 
c  Fortran  77 

c  all  rights  reserved  by  the  author 
c  integrations  use  Weddle's  rule  over  angles 
c  integrations  use  Simpson' s  rule  over  r 


APPENDIX  C 

LISTING  OF  THE  LOPAS  PROGRAM  SUBROUTINES 
FOR  BOTH 

UNI-PROCESSOR  and  PARALLEL  PROCESSOR 


A.  B.  Kunz ,  Author 
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Subroutine  moments (nbfs, ibb, ilpss) 
c  calculates  V00  potential  for  this  building  block 
c  calculates  moments  as  well 

c  uses  spherical  coordinates  and  3-d  numerical  quadrature 
c  authored  by  A  B  Kunz 

c  Fortran  77 

c  all  rights  reserved  by  the  author 

c  integrations  use  Weddle's  rule  over  angles 

c  integrations  use  Simpson's  rule  over  r 
c  weighting  factors  are  used  to  define  each 

c  specific  integrations  properties  and  as  an 

c  aid  to  high  speed  computation.  This  reduces  each 

c  integral  to  a  dot  product,  and  facilitates  vectorization 

c  by  a  smart  compiler 

c 

c»««**************************************************************** 

c 

implicit  real*8 (a-h, o-z) 

dimension  rho (81, 37,73),r(81),ril(37,73),ri2(73),wr(81), 
lwal (37) ,wa2 (73) ,ntype(180)  ,nfirst (180) ,nlast (180) , 

2fodm'180, 180) , tl (218781)  ,t2  (2187  81) ,t3 (218781) , nr (20 
3,3)  ,t5 (81, 37, 73) ,t4  (81,  37, 73) ,  eta (1024 , 5) , c  (1024) 

4, elmom(4, 6, 6, 6) ,ps (360)  ,v(81),vl(81),v2(81) 
common/angle/angl (73) ,  cangl (73) ,  sangl (73) 
common/mompot/vlist (1024,4) , ntype, nf irst, nlast, eta, c 
real*8  norm 

real*4  ain (180) ,psi (2, 180, 180) 
characterM  zl(20) 
character*15  mol51{20) 

character* 11  mol5a (20) , mol 11 (20)  ,mol04  (20) ,mol30  (20) , mol 41  (20) 
lmol40 (20) 

equivalence (t3 (1) , rho (1, 1,1)) 
equivalence  (t4 (1, 1, 1) ,tl  (1) ) 
equivalence (t5(l,l,l),t2(l)) 

data  nr  /  0, 1, 0, 0, 2,  0,  0  1, 1, 0, 3,  0,  0, 2, 2, 1, 0, 1, 0, 1, 

x  0,0, 1,0, 0,2, 0,1, 0,1, 0,3, 0,1, 0,2, 2, 0,1,1, 

x  0,0, 0,1, 0,0, 2, 0,1, 1,0, 0,3, 0,1, 0,1, 2, 2,1  / 

c 

£**#********★*********★***★**********★★★★*★**★***★********•*******★★★ 

c 

mol 51 (1) *' /work/psiOl .dat' 
mol 51 (2) «' /work/psi02 . dat ' 
mol51 (3) »' /work/psi03.dat' 
mol 51 (4) *' /work/psi04 .dat' 
molSl (5)-' /work/psi05.dat' 
mol 51 (6) *' /work/psi06.dat' 
mol51 (7)  /work/psi07 .dat' 
mol 51 (8) -' /work/psi08 . dat' 
mol 51 (9)  -' /work/psi09.dat' 
mol 51 (10) — ' /work/psilO.dat' 
mol 51 (11) »' /work/psill .dat' 
mol51 (12)-' /work/psil2.dat' 
mol51  (13) -' /work/psil3.dat' 
mol 51  (14) -' /work/psil4 .dat' 
mol 51 (15) “' /work/psil5 .dat' 
mol51 (16)-' /work/psil6.dat' 
molSl (17)*' /work/psil7.dat' 
molSl (18) “' /work/psil8 .dat' 
mol51 (19) -' /work/psil9.dat' 
molSl (20)-'/work/psi20.dat' 
mol5a (1) “'mol5a01 .dat' 
mol5a (2) -'mol5a02.dat' 
mol 5a (3) -'mol5a03 .dat' 
mol  5a (4) -'mol5a04 .dat' 
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mol5a (5)-'mol5a05.dat' 
mol5a  (6)-'mol5a06.dat' 
mol5a  (7)-'mol5a07.dat' 
molSa (8) -'mol5a08.dat' 
mol5a (9) -,mol5a09.dat' 
mol5a (10) -'mol5al0 . dat' 
mol 5a (11) -'mol5all .dat' 
molSa (12) «'mol5al2 .dat' 
mol5a (13)-'mol5al3.dat' 
mol5a  (14) -'mol5al4 .dat' 
mol5a (15) -'mol5al5 . dat' 
molSa (16) -'mol5al6 . dat' 
mol 5a (17) -'mol5al7 . dat' 
mol5a  (18) -'mol5al8 .dat' 
mol 5a (19) -'mol5al9 . dat' 
mol 5a (20) «'mol5a20 .dat' 
mol 11 (1)-' molll01.dat' 
molll (2)-'molll02.dat' 
molll  (3) “'moll 103 .dat' 
molll (4) “'molll04 .dat' 
molll (5) “'molll 05 .dat' 
molll  (6) “'molll06.dat' 
molll (7) -'moll 107 .dat' 
molll (8) “'molll 08 .dat' 
molll (9) “'molll09.dat' 
molll  (10) -'mollll0.dat' 
molll (11) “'molllll .dat' 
molll  (12) -'mollll2.dat' 
molll (13) -'mollll3.dat' 
molll  (14) -'molll 14 .dat' 
molll  (15) -'mollll5.dat' 
molll  (16)  -'mo  11116 .  d?t.' 
molll  (17) moll 117 . dat' 
molll (18) -'mollll8.dat' 
molll  (19) “'mollll9.dat' 
molll  (20) “'mol 1120 -dat' 
mol 30  (1) -'mol3001.dat' 
mol30  (2)-'mol3002.dat' 
mol 30  (3) “'mol3003 .dat' 
mol 30 <4)-'mol3004.dat' 
mol 30 (5) “'mol3005.dat' 
mol 30 (6) -'mol3006.dat' 
mol 30  (7) -'mol 3 007 . dat' 
mol 30  (8) -'mol 3 008 -dat' 
mol 30  (9) “'mol3009.dat' 
mol 30  (10) -'mol3010 . dat' 
mol30  (11) “'mol3011 . dat' 
mol 30 (12) -'mol 30 12 .dat' 
mol30  (13)-'mol3013.dat' 
mol 30  (14) -'mol3014.dat' 
mol30(15)-'mol3015.dat' 
mol 30  (16) -'mol3016 . dat' 
mol 30  (17) -'mol3017.dat' 
mol30  (18) -'mol3018.dat' 
mol 30 (19) -'mol3019 .dat' 
mol 30  (20) -'mol 3020 .dat' 
mol04 (1) -'mol0401 .dat' 
mol04  (2) -'mol0402 .dat' 
mol 04  (3) -'mol0403.dat' 
mol 04 (4) -'mol0404.dat' 
mol04  (5) -'mol0405.dat' 
mol04 (6) -'mol0406.dat' 
mol04 (7)-'mol0407.dat' 
mol04 (8)-'mol0408.dat' 
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mol 04 (9) -'mol0409.dat' 
mol 04 <10)«'mol0410.dat' 
mol04 (11)-'  mol0411.dat' 
mol 04 (12)-'mol0412.dat' 
mol 04 <13)-'mol0413.dat' 
mol04 (14) *'mol0414 .dat' 
mol04 (15) -'mol0415.dat' 
mol04 (16)*'mol0416.dat' 
mol 04 (17) *'mol0417 .dat' 
mol 04 (18) -'mol0418.dat' 
mol 04 (19) -'mol0419.dat' 
mol 04 (20) -'mol0420.dat' 
mol40(l)-'mol4001 .dat' 
mol 40 (2) -'mol4002.dat' 
mol 40 (3) -'mol4003.dat' 
mol 40 (4) -'mol4004.dat' 
mol 40 (5) -'mol4005.dat' 
mol 40  ( 6)  -' mol4006.dat' 
mol 40 (7) »'mol4007 .dat' 
mol 40 (8) -'mol4008.dat' 
mol 40 (9) «'mol4009.dat' 
mol 4  0  (10) -'mol4  010.dat' 
mol 40 (11) »'mol4011 .dat' 
mol 40 (12) »'mol 4 012 .dat' 
mol 40 (13) «'mol4013 .dat' 
mol40 (14) -'mol4014.dat' 
mol 40 (15) “'mol4015.dat' 
mol 40 (16) -'mol4016.dat' 
mol 40 (17) »'mol4017 .dat' 
mol 40 (18) »'mol4018 .dat' 
mol 40 (19)*' mol4019.dat' 
mol40 (20) mol 4 020 . dat' 
mol 41 (1)-' mol4l01.dat' 
mol41 (2) -'mol4102.dat' 
mol 41 (3)»' mol4l03.dat' 
mol 41 (4) -'mol4104.dat' 
mol 41 (5) *' mol4l05.dat' 
mol 41 (6) “'mol4106.dat' 
mol 41 (7)»'mol4l07. dat' 
mol 41 (8) -'mol4108.dat' 
mol 41 (9) -'mol4l09.dat' 
mol 41 (10) -'mol4110.dat' 
mol 41 (11)*' mol4111.dat' 
mol41 (12) *'mol4112 .dat' 
mol41 (13) -'mol4113.dat' 
mol 41 (14) *' mol 4 114 .dat' 
mol 41 (15) *'mol411£ .dat' 
mol 41 (16)*' mol4116.dat' 
mol41 (17) -'mol4117.dat' 
mol 41 (18) -'mol4118.dat' 
mol 41 (19) -'mol4119.dat' 
mol 41 (20) -'mol4120.dat' 

c 

c************************************ 


c  set  up  initial  integration  meshes  now 
c  linear  meshes  over  angle 

c  logarithmic  mesh  over  radius 

h«-6 . 9 
del-0.12375 
r  (l)-exp(h) 
do  100  i-3,81,2 
h-h+del+del 
r(i)-exp(h) 

X! 
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100  r(i-l)-0.5* (r(i)+r(i-2) ) 
dang-0 . 087266463 

c  set  up  integration  weight  tables 

c  angular  integrals  use  weddle's  rule  on  equal  integrvals 

c  and  theta  integral  is  sin (theta)  weighted  as  well 

c  radial  integrals  are  using  simpson's  rule  for  changing  mesh 
wr(l)-(r(2)-r(l))/3.0 
wr(81)-(r(81)-r(80))/3.0 
do  101  i-2,78,2 

wr (i)  - (r (i) -r(i-l) ) *1.3333333333333 

101  wr  (i+1) - (r (i+2) -r (i) ) /3 . 0 
wr(80)-(r(81)-r<80) ) *1.333333333333 
do  99  i-1,81 

99  wr(i)«wr(i)*r(i)*r(i) 

do  102  i-1,36,6 
wal  (i) -2 . 0 
wal (i+1) -5. 0 
wal (i+2) “1 . 0 
wal (i+3) *6 . 0 
wal (i+4) *1 . 0 
wal (i+5) ”5 . 0 

102  continue 
wal (1) *1 . 0 
wal (37) “1 . 0 
dmul-0 . 3*dang 
do  103  i-1,37 
th-float ( i — 1 ) *dang 

103  wal (i) -wal (i) *dmul*sin (th) 
do  104  i-1,72,6 
wa2(i)-2.0 

wa2 (i+1) *5 . 0 
wa2 (i+2) -1 . 0 
wa2 (i+3) «6 . 0 
wa2 (i+4 ) -I . 0 
wa2 (i+5) -5 . 0 

134  continue 

wa2 (1) *1 . 0 
wa2 (73) -1.0 
do  105  i-1,73 
105  wa2 (i) -dmul*wa2 (i) 
c  integration  factors  set 
nfmx-180 
ngmx-1024 
ncmx-1024 
ntmx-20 
maxtyp-0 
ilopas-0 
i read-1 

call  poly (ibb, ilopas, iread, nbf s,  non) 
close (unit-60) 
close  (unit-5) 

c 

£«***  *****************************************************  *******^*****^ 

c 

c  form  electronic  charge  density  now 
c  read  in  wave  function  coeficients 
c 

c*********************************************************************** 

c 

open (unit-4, file-mol04 (ibb) , form=' formatted' ) 
read(4, 108) zl 
read (4, 109) nup, ndn, nbas 
k-0 

format (8i4) 


1r ^ 


70 


lopas.sub  Fri  Apr  5  11:22:53  1991  5 

close (unit-4 ) 

open (unit-30, f ile-mol30 (ibb) ,  form-'  unformatted' , 
laccess-' direct' , recl-720) 
id30-3 

do  106  i-l,nup 
read(30, rec-id30) ain 
id30-id30+l 
do  106  j«l,nbas 

106  psi (1, i, j) -ain  ( j) 
id30-nbas+3 

do  107  i-l,ndn 
read (30, rec-id30) ain 
id30-id30+l 
do  107  j»l,nbas 

107  psi (2, i, j ) -ain ( j ) 
close  (unit-30) 

c 

£*****★★*★******★*★***★***★★★*****★■*★*****★*****************★**★*★******* 

C 

c  all  coeficients  available 
c  zero  rho  here 

c 

£***★★****★*★★*********★*★***********★****★*★*■*;*★■*****■**★■*★★**********★★* 

C 

do  110  i-1,81 
do  110  j-1,37 
do  110  k-1,73 
110  rho  (i,  j,  k)  -0  .  C 

108  format (20a4) 

109  format(20i4) 

open (unit=bi, f ile=mol51 (ibb)  ,  form-' unformatted' , 
laccess-' direct' , reel-1750248) 
c 

c  form  basis  functions  first 

c 

if (ilpss . gt . 1 )  go  to  750 

do  1100  nn=l,nbfs 

il-ntype (nn) 

ll«nr  (il, 1 ) 

ml-nr  (il, 2) 

nl=nr (il, 3) 

do  1110  i-1,81 

rr-r (i) 

do  1110  j-1,37 
xy-rr*sangl ( j ) 
zz«rr*cangl ( j ) 
do  1110  k-1,73 
t4 (i, j, k) -0 . 0 
xx-xy*cangl (k) 
yy-xy*sangl (k) 

c  cartesian  coordinates  are  formed 
c  get  amplitude  of  basis  functions  here 
do  1110  1-nf irst  (nn) , nlast (nn) 
x-eta  (1,1) 
y=eta  (1,2) 
z=eta  (1,3) 
expnt-eta  (1,4) 
xnorm-eta (1,5) 
dx-xx-x 

dy.yy-y 

dz-zz-z 

dr-dx*dx+dy*dy+dz*dz 

go  to (3000, 3001, 3002, 3003,3004,3005, 3006,3007,3008,3009, 3010, 
13011,3012,  3013,o.  !.4,  3015,3016,  3017, 3018, 3019)  il 
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3000  angr-xnorm 
go  to  3020 

3001  angr-xnorm*dx 
go  to  3020 

3002  angr-xnorm*dy 
go  to  3020 

3003  angr-xnorm*dz 
go  to  3020 

3004  angr-xnorm* dx*dx 

go  to  3020 

3005  angr-xnorm*dy*dy 
go  to  3020 

3006  angr«xnorm*dz*dz 
go  to  3020 

300"  angr-xnorm*dx*dy 
go  to  3020 

3008  angr-xnorm*dx*dz 
go  to  3020 

300S  angr-xnorm*dy*dz 
go  to  3020 

301C  angr-xnorm*dx*dx*dx 
go  to  3020 

3011  angr«xnorm*dy*dy*dy 
go  to  3020 

3012  angr-xnorm*dz*dz*dz 
go  to  3020 

3013  angr-xnorm*dx*dx*dy 
go  to  3020 

3014  angr-xnorm*dx*dx*dz 
go  to  3020 

3015  angr-xnorm*dx*dy*dy 
go  to  3020 

3016  angr-xnorm*dy*dy*dz 
go  to  3020 

3017  angr-xnorm*dx*dz*dz 
go  to  3020 

3015  angr-xnorm*dy*dz*dz 
go  to  3020 

3019  angr-xnorm*dx*dy*dz 

302C  continue 

rad«exp (-expnt*dr) 

111C  t4(i,j,k)=»t4(i,  j,k)+angr*rad 

c 

c  wave  function  formed,  write  it  to  disc 
c 

110:  write (51, rec*nn) tl 
75C  continue 
c 

c  form  electronic  charge  density  now 


do  121  i-1, 218781 

121  t3(i)-0.0 

do  122  i»l,nup 
do  123  j-1, 218781 

123  t2(j)-0.0 

do  124  j«l,nbas 
read(51, rec-j)tl 
do  124  k-1, 218781 

124  t2(k)«t2(k)+tl(k)*psi(l,i,j) 
do  122  k-1, 218781 

122  t3(k)-t3(k)+t2(k)*t2(k) 
do  125  i«l,ndn 

do  126  j-1, 218781 
126  t2 ( j) -0 . 0 
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do  127  j-l,nbas 
read(51, rec- j) tl 
do  127  k-1, 218781 
127  t2(k)-t2(k)+tl(k)*psi(2,i, j) 
do  125  k-1, 218781 
125  t3 (k)«t3 (k)+t2 <k) *t2 (k) 
close (unit-51) 
c 

q*  *********************************************************************  * 

c 

c  electronic  charge  density  formed 
c  compute  moments 
c  compute  V00  potential 
c 

£1 k********************************************************************** 

C 

c  get  the  monopole  moment 
do  131  k-1, 73 
do  131  j-1,37 
ans-0 . 0 
do  132  i=l, 81 

132  ans-ans+rho (i, j , k) *wr (i ) 

131  ril ( j,  k) -ans 

do  133  k-1, 73 
ans-0 . 0 
do  134  j-1,37 

134  ans-ans+ril ( j,k) *wal  ( j) 

133  ri2(k)-ans 
ans-0 . 0 

do  135  k-1, 73 

135  ans=an3+ri2 (k) *wa2 (k) 

c  electronic  part  of  monopole  moment  complete 

c  add  in  the  nuclear  part 

sum-0 . 0 

do  136  i=l,non 

136  sum-sum+vlist (i, 4) 

c  nuclear  part  on  hand 

c  monopole  moment  is  xmon-sum-ans 
xmon-sum-ans 

c  monopole  moment  found 
c  get  dipole  moments  next 
c  do  electronic  part  first 
elx-0 . 0 
ely=0 . 0 
elz-0 . 0 

open (unit-40,  f ile=mol40 (ibb)  ,  f orm=' unformatted' ) 
write (40) rho 
c  px  first 

do  140  i-1,81 
do  140  j-1,37 
th-f loat  <  j — 1 ) *dang 
sth-sangl ( j) 
do  140  k-1, 73 
phi-float (k-1) *dang 

14  0  rho  <i, j, k) -rho (i, j, k) *cangl (k) *sth*  r (i) 
do  141  k-1, 73 
do  141  j-1,37 
ans-0 . 0 
do  142  i-1,81 

142  ans-ans+rho (i, j, k) *wr (i) 

141  ril ( j, k) -ans 
do  143  k-1, 73 
ans-0 . 0 

do  144  j-1,37  ^ 
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144  ans-ans+ril ( j, k) *wal ( j) 

143  ri2(k)-ans 

do  145  k-1,73 

145  elx-elx+ri2 (k) *wa2 (k) 
c  do  py  next 

rewind  40 
read (40) rho 
do  150  i-1,81 
do  150  j-1,37 
th«float ( j-1) *dang 
sth-sangl ( j) 
do  150  k-1,73 
phi-float (k-1) *dang 

150  rho (i, j, k) -rho (i, j, k) *sangl (k) *sth*r  (i) 
do  151  k-1,73 

do  151  j-1,37 
ans-0 . 0 
do  152  i-1,81 

152  ans-ans+rho (i, j, k) *wr (i) 

151  ril(j,k)«ans 
do  153  k-1,73 
ans-0. 0 

do  154  j-1,37 

154  ans-ans+ril (j, k) *wal (j) 

153  ri2(k)-ans 

do  155  k-1,73 

155  ely«ely+ri2 (k) *wa2 (k) 
c  do  pz  next 

rewind  40 
read (40) rho 
do  160  i-1,81 
do  160  j-1,37 
th-float (j-1) *dang 
cth-cangl ( j) 
do  160  k-1,73 

160  rho (i, j, k) -rho (i, j, k) *cth*r (i) 
do  161  k-1,73 

do  161  j-1,37 
ans-0 . 0 
do  162  i-1,81 

162  ans-ans+rho (i, j, k) *wr  (i) 

161  ril ( j, k) -ans 
do  163  k-1,73 
ans-0 . 0 

do  164  j-1,37 

164  ans-ans+ril (j,k) *wal (j) 

163  ri2(k)*ans 

do  165  k-1,73 

165  elz-elz+ri2 (k) *wa2 (k) 

c  add  in  nuclear  part  next 

c  px,py,pz  together 

xneg— 1 . 0 
elx-elx*xneg 
ely-ely*xneg 
elz-elz*xneg 
do  170  i-l,non 

elx-elx+vlist (i, 4) *vlist (i, 1) 
ely-ely+vlist (i, 4) *vlist (i, 2) 

170  elz-elz+vlist (i, 4) *vlist (i, 3) 

open (unit-60,  file-' moments . dat' ,  form-' formatted' ) 
write (60,171) xmon, elx, ely, elz 
print  171, xmon, elx, ely, elz 

171  formatdx,'  net  charge  -  ',fl2.4,//, 

1'  px  -  ' , f 12 . 4, '  py  -  ' , f 12 . 4 , '  pz  -  ',fl2.4) 
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c 

c  do  the  general  multipole  term  now 
c 

lmax-5 

if  (lmax.le.l)  go  to  207 
do  200  m-2,lmax 
do  200  nl-0,m 
do  200  n2«0,m 
do  200  n3-0,m 

if  ( (nl+n2+n3) . ne .m)  go  to  200 

rewind  40 

read (40) rho 

do  201  i-1,81 

rr-r(i) 

do  201  j-1, 37 

z-rr*cangl ( j) 

xy-rr*sangl ( j) 

do  201  k-1,73 

x=xy*cangl (k) 

y=xy*sangl (k) 

if (nl.eq.O)x-l. 

if (n2 . eq. 0)  y-1 . 

if (n3.eq. 0) z=l . 

2 Cl  rho  (i,  j,  k)  -rho  (i,  j,  k)  *  (x**nl)  *  (y**n2)  *  (z**n3) 

do  202  k-1,73 
do  202  j-1,37 
ana-0 . 0 
do  203  i-1,81 

2C3  ans-ans+rho (i, j,k) *wr  (i) 

202  ril ( j, k) -ans 

do  204  k-1,73 
ans-0 . 0 
do  205  j-1,37 

2C5  ans-ans+ril ( j, k) *wal  ( j) 

2C4  ri2(k)=ans 

sum-0 . 0 
do  206  k-1,73 

2C6  sum=sum+ri2 (k) *wa2 (k) 

sum=-sum 


c 

q  ****************************************************************** 

C 

c  add  in  nuclear  part  now 

c 

Q  ****************************************************************** 

C 

do  208  i-l,non 
xnuc-vlist (i, 1 ) **nl 
ynuc-vlist (i, 2) **n2 
znuc-vlist (i, 3) **n3 
if (nl .eq. 0) xnuc-1 . 
if (n2 .eq. 0) ynuc=l . 
if (n3 . eq. 0) znuc-1 . 

2C8  sum-sum+vlist (4, i) *xnuc*ynuc*znuc 
elmom(m-l, nl+1, n2+l, n3+l) -sum 
write (60,209)nl,n2,n3, sum 

209  format('  nx  ',i4,'  ny  ',i4,'  nz  ',i4,'  monent  -  ',fl2.6) 

200  continue 

207  continue 

close (unit-60) 


c 

c 

c 

c 


moments  up  to  1-5  have  been  computed 
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c 

c  **************************************************************** 

c 

c 

2********************************************************************* 

c 

c  compute  spherical  part  of  the  potential 

c  get  spherically  averaged  charge  density  first 

c 

q*  *  *  *  *  *  ★  *  *  *  *  *  *  *  *  ★  *  *  *  *  *  *  *  **************  ★  ★  *  *  *  *  *  ★  *  ★  *  *  ★  *  *  *  *  *  *  *  *  *  *  ★  *  ★  *****  * 

C 

rewind  40 
read (40)  rho 
close  (unit-40) 
do  180  i-1, 81 
do  180  j-1,37 
ans*0 . 0 
do  181  k-1,73 

181  ans*ans+rho (i, j, k) *wa2 (k) 

180  ril (i,  j) -ans 

do  182  i-1,81 
an3*0 . 0 
do  183  j-1,37 

183  ans»ans+ril (i, j) *wal  ( j) 

182  ri2(i)«ans 

c  spherical  rho  is  in  ri2  here 

vl (l)«0.5*r(l) *r (1) *ri2 (1) 
v2 (1) “0 . 5*r (1) *ri2 (1) 
do  190  i-2,81 
h»(r(i)-r(i-l) )*0.5 

al-(r(i) *r (i) *ri2 (i) +r (i-1 ) *r (i-1 ) *ri2 (i-1) ) 
a2= (r (i) *zi2 (i) +r (i-1 ) *ri2 (i-1) ) 
vl (i) =vl (i-1) +h*al 

190  v2  (i)  =»v2  (i-1 )  +h*a2 
do  191  i-1,81 

191  v(i)-vl (i)/r(i)+v2 <81)-v2(i) 

c  electronic  part  of  the  potential  determined 
c  add  in  the  nuclear  part  next 

do  192  i-1, non 
do  192  j-1,81 
zl-vlist (i, 4) 

rl-vlist (i, 1) **2+vlist (i, 2) **2+vlist (i, 3) **2 
rl»3qrt (rl) 
if (r ( j ) . gt . rl)  then 
v< j)»v( j) -zl/r ( j) 
else 

v( j)-v( j) -zl/rl 
endif 

192  continue 

c  all  potential  terms  are  on  hand 

open (unit-41, file=mol41 (ibb) , form-'  unformatted' ) 
write (41 ) xmon, elx, ely, elz, v, elmom 
close (unit-41) 
return 
end 
c 

c 

c  This  subroutine  generates  the  external  potential  seen  by  the 

c  i  th  molecular  buildingblock.  The  potential  will  be  generated 

c  using  a  numerical  mesh  sited  about  the  i  th  buildingblock. 

c  Matrix  elements  of  this  potential  with  the  basis  vectors 

c  on  the  i  th  buildingblock  will  also  be  evaluated  using  numerical 

c  techniques . 
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c 

c  written  in  Fortran  77 

c  A  B  KUNZ  at  MTU  in  1990 
c  all  rights  are  reserved  by  the  author 

c 

Q  ★  *********★**★****★★***★****★★*****★***★**************★***★*****★ 

C 

subroutine  pot (nbfs, ilps, nenv, xof , yof , zof , a, b, c2, ilO, id) 
implicit  real*8 (a-h, o-z) 

dimension  nenv (20) ,  xof (20,200)  ,  yof (20,200) , zof (20,200),a(20,200), 
lb (20, 200) ,c2  (20,200) , id (20, 200)  ,r (81) ,v (81, 37, 73) ,pl (81,37,73) , 
2p2  (81,37,73) ,tl (218781)  ,t2  (218781) , ril (37, 73) , ri2 (73) ,wr (81) ,wal ( 
337) ,wa2 (73) , exv (1024) , iii (1024) , j j j (1024) , u <81 ) , zint (81, 37, 73) , 
4ntype(180) ,nfirst  (180),nlast(180), 

5t3 (218781) ,t4  (218781)  ,t5  (27  01)  ,  nr (2  0 , 3) , eta ( 

61024,5) ,elmom (4, 6,6,6)  ,c (1024) 
common/angle/angl (73) , cangl (73) , sangl (73) 
common/mompot/vlist (1024,4)  , ntype, nf irst , nlast , eta, c 
integer*2  iii , j  j  j 

equivalence (pi (1, 1, 1) , tl U) ) ,  (p2 (1, 1, 1) , t2  (1) ) 

equivalence (t3(l),v(l,l,l)),  (t4(l); zint (1,1,1)), (t5 (1) ,  ril  (1, 1) ) 
characterM  zl(20) 

character*ll  molll (20)  ,mol41 (20) ,mol52 (20) 
character*15  mol51(20) 

data  nr  /  0, 1, 0, 0, 2, 0,  0, 1, 1 , 0, 3,  0,  0, 2, 2, 1, 0, 1, 0, 1,  - 

x  0,0, 1,0, 0,2, 0,1, 0,1, 0,3, 0,1, 0,2, 2, 0,1,1, 

x  0,0, 0,1, 0,0, 2, 0,1, 1,0, 0,3, 0,1, 0,1, 2, 2,1  / 

c 

£******************************»*****«********************************* 

c 


mol 51 (1)  =  ' /work/psiOl .dat' 
mol 51 (2)=' /work/psi02 . dat ' 
mol 51  (3)  ='  /work/psi03.dat' 
mol 51  (4 )  =  '  /work/psi04  .  dat' 
mol 51 (5)  =' /work/psi05 . dat' 
mol 51 (6)  =' /work/psi06.dat' 
mol51 (7) =  ' /work/psi07 . dat' 
mol 51 (8)  =' /work/psi08 .dat' 
molSl (9)*' /work/psi09.dat' 
mol 51 (10) •' /work/psilO .dat' 
mol51 (11)=' /work/psill .dat' 
mol51 (12) =' /work/psil2 .dat' 
mol 51 (13) =' /work/psil3.dat' 
mol 51 (14) •' /work/psil4 .dat' 
mol 51 (15) =' /work/psil5 . dat' 
mol51 (16)=' /work/psil6.dat' 
mol 51 (17) =' /work/psil7 .dat' 
mol 51 (18) »' /work/psil8 .dat' 
mol51 (19) =' /work/psil9.dat' 
mol 51 (20) »' /work/psi20 .dat' 
mol 41 (1) -'mol4101.dat' 
mol41 (2) -'mol4102.dat' 
mol 41 (3) *' mol 4 103. dat' 
mol41 (4) -'mol4104.dat' 
mol 41 (5) -'mol4105.dat' 
mol41 (6)='mol4106.dat' 
mol41 (7) -'mol4107.dat' 
mol41 (8)-'mol4108.dat' 
mol41 (9) =' mol4109.dat' 
mol 41 (10) -'mol4110.dat' 
mol 41 (11) -'mol4111.dat' 
mol 41 (12) -'mol 4 112 .dat' 
mol 41 (13) -'mol4113.dat' 
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mol41(14)-'mol4114.dat' 
mol41 (15) -'mol4115.dat' 
mol41 (16)-' mol4116.dat' 
mol41(17)-'mol4117.dat' 
mol 41 (18) -'mol4118.dat' 
mol41 (19) -'mol4119.dat' 
mol 41 (20)-'mol4120 .dat' 
mol 52 (1) -'mol5201 .dat' 
mol52 (2) -'mol5202.dat' 
mol52 (3)-'mol5203.dat' 
mol52 (4) -'mol 52 04 .dat' 
mol52(5)-'mol5205.dat' 
mol 52 (6) -'mol5206.dat' 
mol 52 (7) -'mol5207.dat' 
mol52 (8) -'mol5208.dat' 
mol 52 (9) »'mol5209 .dat' 
mol52 (10) -'mol5210.dat' 
mol 52 (11 ) -'mol 52 11 .dat' 
mol52 (12) -'mol5212.dat' 
mol 52  (13)  »'  mol 521 3 .  dat' 
mol52 (14) -'mol5214.dat' 
mol52 (15) -'mol5215.dat' 
mol52 (16) -'mol5216 .dat' 
mol52 (17) -'mol5217.dat' 
mol 52 (18) -'mol5218.dat' 
mol52(19)-'mol5219.dat' 
mol52 (20) -'mol5220 .dat' 
c 

£**«««****************************************************************** 

C 

c  set  up  initial  integration  meshes  now 
c  linear  meshes  over  angle 

c  logarithmic  mesh  over  radius 

open (unit-52,  f ile-mol52 (ilO) , form=' unformatted' ) 
open  (unit-51,  file«mol51  (ilO) ,  form.-'  unformatted' , 

1 access-' direct' , reel-1750248) 
ilst-1 
if rst-0 
ibb-ilO 
h— 6.9 
del-0.12375 
r (1)  -exp (h) 
do  1000  i-3,81,2 
h-h+del+del 
r (i) -exp (h) 

10:3  r (i-1) -0 . 5* (r(i)+r(i-2) ) 
dang-0 .087266463 

c  set  up  integration  weight  tables 

c  angular  integrals  use  weddle's  rule  on  equal  integrvals 

c  and  theta  integral  is  sin (theta)  weighted  as  well 

c  radial  integrals  are  using  simpson's  rule  for  changing  mesh 
wr(l)«(r(2)-r(l))/3.0 
wr (81)  - (r (81) -r  (80) ) /3. 0 
do  1001  i-2,78,2 

wr(i)-(r(i)-r(i-l) >*1.3333333333333 
10:i  wr(i+l)»(r(i+2)-r(i))/3.0 

wr (80)- (r< 81) -r ( 80) >*1.333333333333 
do  99  i-1,81 

95  wr(i)-wr(i)*r(i)*r(i) 

do  102  i-1,36,6 
wal (i) -2 . 0 
wal (i+1) -5. 0 
wal (i+2) -1 . 0 
wal (i+3) -6 . 0 


Qo 
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wal (i+4) -1 . 0 
wal (i+5) *5 . 0 

102  continue 
wal (1)-1.0 
wal (37) «1 . 0 
dmul-0.3*dang 
do  103  i-1,37 
th-float ( i— 1 ) *dang 

103  wal (i) -wal (i) *dmul*sin (th) 
do  104  i-1,72,6 

wa2 (i) -2 . 0 
wa2 (i+1) -5 . 0 
wa2 (i+2) *1 . 0 
wa2 (i+3) “6 . 0 
wa2 (i+4) *1 . 0 
wa2 (i+5) *5 . 0 

104  continue 
wa2(l)«1.0 
wa2 (73) -1.0 
do  105  i-1,73 

105  wa2 (i) -dmul*wa2 (i) 

c  integration  factors  set 

c 

£****★★*****★★★***★★**★*★*************★★**********★***★*★★**★****★★**★** 

c 

c  all  wavefunctions  are  on  file  51  and  are  direct  access 
c  form  the  environmental  potential  for  this  buildingblock 

c  initially  forn  vOO  part 

c  potential  i3  the  full  potential  and  includes  ionic  parts 
c 

£**★****★★★*★★**★***★********★**★*★**********★***■*★★*★★**★★★★★★*★★★★**★★ 

C 

do  120  i-1,81 
do  120  j-1,37 
do  120  k-1,73 

120  v (i, j, k) =0 . 0 

do  200  ia»l,nenv (ilO) 
ib-id (ilO, ia) 
x=xof  (ilO, ia) 
y«yof (ilO, ia) 
z-zof (ilO, ia) 

open (unit-41,  file=mol41 (ib) , f orm=' unformatted'  ) 
read  (41) xion, elx, ely, elz, u, elmom 
close  (unit-41) 
c 

Q  ******************************************************************* 

c 

c  do  setup  for  multipole  moments  here,  do  rotations  of  coords 
c  go  from  body  coordinates  to  space  coordinates 

c  use  Euler  agles  and  Cayleigh-Klean  parameters 

c  actual  implementation  is  only  for  dipoles 

c 

Q  **★**★*★★**★*★*★★**★****★**★***★******■**★*★★*★★★★*★★**★★**★*★****★* 

C 

aa-a (ilO, ia) 
bb-b (ilO, ia) 
ccc«c2 (ilO, ia) 
sa-sin (aa) 
ca-cos (aa) 
sb-sin (bb) 
cb-cos (bb) 
sc-sin (ccc) 
cc-cos (ccc) 
vll«cc*ca-cb*sa*sc 


Qi 


lopas . sub 


Fri  Apr  5  11:22:53  1991 


14 


c 

c 

c 

c 

c 

c 

c 

c 

201 

c 


c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 

c 


vl2--sc*ca-cb*sa*sc 

vl3-sb*sa 

v21-cc*sa+cb*ca*sc 

v22— sc*sa+cb*ca*cc 

v23— sb*ca 

v31-sb*sc 

v32-sb*cc 

v33-cb 

px-vll*elx+vl2*ely+vl3*elz 

py=v21*elx+v22*ely+v23*elz 

pz»v31*elx+v32*ely+v33*elz 

******************************************************************** 
rotated  dipoles  found 

can  put  in  rotated  higher  moments  later 
******************************************************************** 

zion-u (81) *r (81 ) 
do  201  i-1,81 
u(i)»u(i)-zion/r(i) 

potential  is  now  missing  its  ionic  tail 

h— 6.9 

del-0.12375 

do  210  i-1,81 

do  210  j-1,37 

do  210  k-1,73 

theta-float ( j  — 1 ) *dang 

phi-float (k-1) *dang 

xx-r (i) *sin (theta) *cos (phi) 

yy-r (i) *sin (theta) *sin (phi) 

zz=r (i) *cos (theta) 

dx-xx-x 

dy-yy-y 

dz=zz-z 

rr-sqrt (dx*dx+dy*dy+dz*dz ) 
v(i,j,k)-v(i, j,k)+xion/rr 
if (i . It . 66. and. rr . It . r (81 ) ) then 
ixa=l+ (dlog (rr) -h) /del 
if  (ixa . It . 1 ) ixa=l 
dr-rr-r (ixa) 
da-dr/ (r (ixa+1) -r (ixa) ) 
dv=u (ixa+1 ) -u (ixa) 
v (i, j, k) -v (i, j, k) +u (ixa) +da*dv 
endif 

***************************************************************** 

add  in  dipole  potential  term  here 
later  add  in  higher  poles 

***************************************************************** 


rsq-rr*rr 
alph-dx/rr 
beta-dy/rr 
gamma -dz/rr 

vd- (px*alph+py*beta+pz*gamma) /rsq 
v  (i,  j,  k)  -v  (i,  j,  k)  +vd 

***************************************************************** 


dipole  potential  included 


on 
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c  later  add  higher  poles  in  like  way 

c 

C  ***************************************************************** 

C 

213  continue 
22  3  continue 
vmax-0 . 0 
do  300  i-1,81 
do  300  j-1, 37 
do  300  k-1,73 

if  (abs (v (i, j,  k) ) .gt .vmax) then 
vmax-abs (v (i, j, k) ) 
imax=i 
jmax- j 
kmax=k 
endif 

333  continue 

write (61 , 301 ) imax, jmax, kmax, r (imax) , vmax 
331  format ('  POT  VMAX  ' , 3i5, 2f 16 . 4) 

write (61,4589)  (v (i,  11 , 3) , i=l, 81) 

4339  format ('  POT  V  ',4fl4.4) 
c 

q*  *  *  *  *  ★  *  *  *  *  *  *  ★  *  Ik  *  *  *  *  *  Hr  *  *  *  *  *  *  *  *  *  *  *  ★  *  *  ★  *  *  *  ★  •*  *  *  *  *  *  *  *  it  it  ★  *  *  *  *  *  *  *  ★  *  *  *  *  *  *  *  ★  *  ★  ★  * 

C 

c  potential  formed  for  this  case 

c  get  matrix  elements 

c 

0*»W******************************************************************** 

c 

ii-0 

do  220  ia=l,nbfs 
read(51, rec-ia) tl 
do  220  ja-l,ia 
ii-ii+1 

read (51 , rec- ja) t2 
do  221  i-1, 218781 
221  t4  (i)  -tl  (i)  *t2  (i)  *t3  (i) 
do  231  j-1, 2701 
ans-0 . 0 
jof-  ( j-1) *81 
do  232  i-1,81 

232  ans-ans+t4  ( jof+i ) *wr (i ) 

231  t5(j)=ans 

do  233  k-1,73 
ans-0 . 0 
kof-(k-l) *37 
do  234  j-1, 37 

234  ans-ans+t5  (kof+ j) *wal ( j ) 

233  ri2  (k) -ans 
sum-0 . 0 

do  235  k-1,73 
235  sum-sum+ri2 (k) *wa2 (k) 
exv (ii) -sum 
iii (ii) -ia 
D  j  j (ii) - ja 
if (ii .eq. 1024 ) then 

write (52) ii, ifrst, iii, j j j, exv 
ii-0 
endif 

220  continue 

write (52)ii,ilst,iii, jjj, exv 
write (61 , 1289) (exv (i) , i-1 , 300) 

1289  format ('  POT  EXV  ',5fl2.4) 
close  (unit-51) 

4?> 
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close  (unit-52) 

return 

end 

c  polyints  program  —  mqm  master  file  log 

c  initial  creation  --  10/28/74  —  bdo 

c  lppoly  local  potential  integral  program  -  written  by  cbm  12-1-70 
c  added  to  previous  polyatom  program 

c . program  modified  to  use  ijlk  or  pair  tapes,  rvb  09/06/75 

c  fortran  iv  program  pa300  (tape3, tape4, input, output, tape5-input, 
c 

subroutine  poly (iblk, ilopas, iread, nbfns, non) 
implicit  double  precision (a-h, o-z) 
real*4tyme (2) 
character* 8tlopot 
character*32naml 

character* 11  mol 11 (20) , mol 5a (20) ,  mol 02 (20) ,  mol 16 (20) ,  mol Or  (20) 
dimension  ncntr (180) , ntype (180) ,  nfirst (180),nlast(180), number (180) 
x,mlist (180) , vlist (1024 , 4 ) , icentr (1024 ) , itype (20), nr (20, 3),  valint ( 
yl024) 

x,eta (1024,5)  ,c(1024)  ,nlab(4)  ,  kcntr (180) , ktype (180) 
dimension  mlab(4) 
common/labels/ilbl (18) , ilab (18) 
c  ommon / e  rgnuc / ene  rgy 

common/inc/x3,x5,x7,x9,xll,xl3,xl5,xl7,xl9,x21,x23,x25 
common/ ioind/ icon (10) , ifile2 
common/names/lname (5) , iname (5) , jname  (5) 
corranon/namtap/nitape, lstnam, notape, intnam, nctape 
common/nmbrs/pi,piterm, pitern,  acrcy, scale, icanon 
common/ specs /icnt, jcnt, kcnt, lent, ityp, jtyp, ktyp, ltyp, is, js, ks, 
lls,if,jf,kf,lf,mfi,j,k,l 

common/ st ore/ st rO (280),strl(280),str2(280),str3(280),str4(280), 
lstr5 (280) , str6  (280) , str7  (280)  ,  str8  (280)  ,  Str9 (280) , 3trl0  (280) , 
2strll (280) ,  strl2  (280) 
common/lptyp/tlopot (1024) 

common/mompot /vlist, ntype, nfirst, nlast, eta, c 
commonvalint 
c  integer  rtime 

equivalence (iconl , icon (1 ) ) , (icon2, icon (2) ) 
equivalence (iconlO, icon (10) ) 

data  nr  /  0, 1, 0,  0, 2, 0, 0, 1, 1, 0,  3,  0, 0, 2, 2, 1, 0, 1, 0, 1, 

x  0,0, 1,0, 0,2, 0,1, 0,1, 0,3, 0,1, 0,2, 2, 0,1,1, 

x  0,0, 0,1, 0,0, 2, 0,1, 1,0, 0,3, 0,1, 0,1, 2, 2,1  / 

data  itype/3hs  , 3hx  , 3hy  , 3hz  , 3hxx  , 3hyy  ,3hzz  , 3hxy  , 3hxz  , 
x3hyz  , 3hxxx, 3hyyy, 3hzzz, 3hxxy, 3hxxz, 3hxyy, 3hyyz, 3hxzz, 3hyzz, 3hxyz/ 
data  mlab/'  slst ' , ' tlst ' , ' vlst ' , '  mist' / 

data  nlab/4hsint, 4htint , 4hvint , 4hmint /, ninmax/1 024/, ncmx/1024/, 
xntmx/20/ 

molll (1) -'molllOl .dat' 
molll (2) -'molll02.dat' 
molll (3) -'molll03.dat' 
molll (4) -'mol 11 04 .dat' 
molll (5) -'molll05.dat' 
molll (6) -'molll06.dat' 
molll (7 ) -'mol 11 07 .dat' 
molll (8) -'molll08.dat' 
molll (9) -'molll09.dat' 
molll (10) -'mollll0.dat' 
molll (11) -'mol 11 11. dat' 
molll (12) -'mollll2.dat' 
molll (13) -'mollll3 . dat' 
molll (14) -'mollll4.dat' 
molll (15)-' mo 11115. dat' 
molll (16) -'mollll6.dat' 

GU 
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molll (17) -'mollll7.dat' 
mol 11 (18)»'mollll8.dat' 
molll (19) -'mollll9.dat' 
molll (20) -'mol 1120 .dat' 
mol5a (1) -'mol5a01 .dat' 
mol 5a (2) -'mol5a02.dat' 
mol 5a (3) -'mol5a03 . dat' 
mol5a (4) «'mol5a04 .dat' 
mol5a (5) -'mol5a05.dat' 
molSa (6) -'mol5a06 . dat' 
mol5a (7) -'mol5a07 .dat' 
molSa (8) -'mol5a08.dat' 
mol 5a (9) -'mol5a09.dat' 
molSa (10) -'mol5al0 . dat' 
mol5a (11 ) -' mol5all . dat' 
molSa (12) -'mol5al2 .dat' 
mol5a (13) -'mol5al3.dat' 
mol5a (14) «'mol5al4 .dat' 
mol5a (15) -'mol5al5.dat' 
mol 5a (16) -'mol5al6.dat' 
mol 5a (17) »' mol Sal 7 .dat' 
mol 5a (18) -'mol Sal 8 .dat' 
mol 5a (19) -'mol5al9.dat' 
molSa (20) ='mol5a20 .dat' 
mol02 (1) -'mol0201  .dat' 
mol02 (2) -'mol0202.dat' 
mol 02 (3) =' mol 0203 . dat' 
mol02 (4) -'mol 02 04 .dat' 
mol 02 (5) -'mol0205 . dat' 
mol 02 (6)='mol0206.dat' 
mol 02 (7) —'mol 02 07 .dat' 
mol02 (8) -'mol0208.dat' 
mol 02 (9) -'mol0209.dat' 
mol02 (10) -'mol0210.dat' 
mol02 (11) -'mol0211.dat' 
mol02 (12) -'mol0212.dat' 
mol 02 (13) -'mol0213.dat' 
mol 02 (14) ='mol0214 .dat' 
mol 02 (15) -'mol0215.dat' 
mol 02 (16) -'mol0216.dat' 
mol 02 (17) -'mol0217.dat' 
mol 02 (18) -'mol 021 8 .dat' 
mol 02 (19) -'mol0219.dat' 
mol 02 (20) -'mol0220.dat' 
moll6(l)-' moll  601. dat' 
mol 16 (2) -'moll602.dat' 
moll 6 (3) -'moll  603. dat' 
mol 16 (4)-'moll604 .dat' 
mol 16 (5) -'moll605.dat' 
mol 16 (6) -'moll606.dat' 
mol 16 (7) -'moll607.dat' 
mol 16 (8) -'moll 608 .dat' 
mol 16 (9) -'moll609.dat' 
moll6 (10) -'moll610.dat' 
moll  6 (11) -'moll611.dat' 
mol 16 (12) -'moll612.dat' 
moll 6 (13) -'mol 161 3 .dat' 
mol 16 (14) -'moll614 .dat' 
moll6 (15) -'moll615.dat' 
moll6 (16) -'moll616.dat' 
mol 16 (17) -'mol 161 7 .dat' 
mol 16 (18) -'moll 61 8 .dat' 
moll6 (19) -'moll619.dat' 
mol 16 (20) -'moll620.dat' 
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mol Or (1) -'molOrOl .dat' 
mol Or (2) *' mol Or 02. dat' 
molOr (3) *'mol0r03 .dat' 
mol0r(4)-'mol0r04 .dat' 
molOr (5) -'mol0r05.dat' 
molOr (6) -'mol0r06.dat' 
molOr (7) -'mol 0r07.dat' 
molOr (8) «'mol0r08 .dat' 
molOr (9) -'mol0r09.dat' 
molOr (10) ='mol0rl0 .dat' 
molOr (11) “'molOrll.dat' 
molOr (12) =' mol 0rl2.dat' 
molOr (13) *' mol 0rl3.dat' 
molOr (14) ='mol0rl4 . dat' 
mol 0  r ( 1 5 ) = ' mol0rl5.dat' 
molOr (16) *' mol Or 16 . dat' 
molOr (17) *'mol0rl7 .dat' 
molOr (18) ='mol0rl8 .dat' 
molOr (19) =' mol0rl9 .dat' 
molOr (20) ='mol0r20 . dat' 
nfmx=180 
ngmx=1024 

nsavmx=ngmx* (ngmx+1) /2 

nctape»2 

nitape=3 

notape=4 

pi«3 . 141 592 653 5 8 97 9d0 
piterm»2 . d0/pi**0 . 5d0 
pitern-pi**l . 5d0 
x3  *  I.d0/3.d0 
x5  -  1 .d0/5 . dO 
x7  =  I.d0/7.d0 
x9  -  I.d0/9.d0 
xll-  l.dO/ 11. dO 
xl3=  l.dC/l3.dO 
xl 5=  1. dO/15. dO 
xl7=  1. d0/17. dO 
xl9=  1. dO/19. dO 
x21=  1 . d0/21 .dO 
x23=  1 .dO/23. dO 
x25=  1. dO/25. dO 

open (unit*5, file=molll (iblk) , form=' formatted' ) 
open (unit=60, file=mol5a (iblk) , form=' formatted' ) 
open (unit=nitape, file=mol02 (iblk) , 

1  form*' unformatted' ) 
open (unit=notape, file=moll6 (iblk) , 
lform=' unformatted' ) 

open (unit^nctape, file=molOr (iblk) , f orm=' unformatted' ) 
i-1 

call  rdinpt (nfmx,  ngmx, ncmx,  ntmx, maxtyp,  nbfns, ngaus, noc, 
x  nlist,c,eta, number, ncntr, ntype, kcntr, ktype, 

x  nf irst,  nlast,mlist,  icentr, vlist , i type, nr, non) 

i=10 

if (iread. ne . 0) return 
if (iconlO . ne. 0) nitape=nctape 
read(nitape) ilab 
write (60, 7787) ilab 
read (nitape) lbnbf 
if (lbnbf .eq.nbfns)gcio7777 
write (60, 950) lbnbf, nbfns 
stop 

7777  write (notape) ilbl 

if (iconlO.eq. 0)goto7788 
read(nitape) 

1b 
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read(nitape) 

read(nitape) 

7788  write (notape) nbfna, (nfirst (i) ,  nlast (i)  , ncntr (i) , ntype (i) , 
x  kcntr (i) , ktype (i) , i-1, nbfns) 
write (notape) ngaus, ( (eta (i,  j) ,  j-1, 4) ,  c  (i) , i-1, ngaus) 
write (notape) noc, ( (vlist (i, j) , j-1, 4) , i-1, noc) 
write (notape) energy, acrcy, scale,  icon (9) , icanon,maxtyp, nlist, 
x (mlist (i) , i-1, nlist) 

c . calculate  the  overlap  integrals  and  check  symmetry 

if (icon2 . ge . 3) goto540 
i-1 

read (nitape) nnna 

if (nnna . ne .mlab (i) . and. nnna . ne . nlab (i) ) goto959 
write (notape) nlab (i) 

540  write  (60,912) 

call  gints (ntype, nr, nfirst, nlast,  eta, nfmx, ntmx, 
x  ninmax, ngmx, nbfns) 

c . calculate  the  kinetic  energy  integrals 

if (icon2 .ge. 3) goto550 
i-2 

read (nitape) nnna 

if (nnna . ne .mlab (i) . and. nnna .ne . nlab (i) ) goto959 
write (notape) nlab(i) 

550  write  (60,913) 

call  tints (ntype, nr, nfirst , nlast , eta, nfmx, ntn;  . 
x  ninmax, ngmx) 

c . calculate  the  potential  energy  integrals 

if (icon2 .ge. 3) goto560 
i=3 

read (nitape) nnna 

if (nnna . ne. mlab (i) . and. nnna .ne . nlab (i) )goto959 
write (notape) nlab (i) 

560  write  (60,933) 

call  vints (non, vlist , ntype, nr, nfirst , nlast , eta, 
x  nfmx, ncmx, ntmx,  ninmax, ngmx) 

if  (  icon <1 ) - eq. 1 ) goto876 

c . calculate  the  2-electron  integrals 

if (icon2 . ge . 3) goto570 
i-4 

read (nitape ) nnna 

if (nnna . ne. mlab (i) .and. nnna. ne.nl ab(i) )goto959 
write (notape) nlab (i) 

570  if (iconl . It . 2) goto580 
write (60,400) 

c . copy  2-electron  integrals 

3 top  '  no  cpycmi  ' 

580  continue 

write  (60,860) 

call  mints (nlist,  mlist , ncntr, ntype, eta, nfirst, nlast , 
x  nr, ntmx, ninmax, ngmx, nsavmx, maxtyp, ngaus ) 

876  endf ilenotape 

772  format  (///'  time  for  1-electron  integrals  =',f6.2, 

2  '  min. sec,  2-electron  integrals  =',f6.2,'  min. sec') 
go  to  901 

959  write (60, 960)  mlab (i) , nlab (i) , nnna 
901  close (unit-5) 
close (unit-60) 
close (unit-nitape) 
close (unit-notape) 
close (unit-nctape) 

8765  format (lx, f 18 . 4, 4x, fl8 . 8) 
return 

7787  format (' ltape  used  for  labels  -  ',18a4//) 

912  format ('  gints  -  evaluate  overlap  integrals'//) 
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913  format ('  tints  -  evaluate  kinetic  energy  integrals'//) 

933  format ('  vints  -  evaluate  potential  energy  integrals'//) 

400  format ('  cpycmi  -  copy  2-electron  integrals'//) 

860  format ('  mints  -  evaluate  2-electron  integrals'//) 

950  format (//10x, '  **  labels  nbfns  «',i4,',  does  not  agree  with 

2  integrals  nbfns  -',i4,'  **'/) 

960  format (//10x, '  **  expecting  ',a4,'  or  ',a4,'f  found  ',a4, 

2  '  **'/) 

2400  format (lx, '  enter  the  name  of  the  polyin  input  file  (file  5)') 
21024  format (a32) 

2600  format (lx, ' enter  the  name  of  the  polyin  information  output 
1  file  (file  6) ' ) 

2700  format (lx, ' enter  the  name  of  the  labels  output  file  (file  3)') 

2800  format (lx, 'enter  the  name  of  the  polyin  output  file  (file  4)') 

2900  format (lx, 'enter  the  name  of  the  polyin  restart  file  (file  2)') 

end 

double  precision  function  ovlap  (l,m, a,b,t) 
implicit  double  precision (a-h, o-z) 

11-1+1 

mm-m+1 

go  to  (100,101,102,103,104,1051,11 

100  go  to  (110, 111,112, 113, 200, 200),mm 

101  go  to  (120,121,122,123,200,200) ,mm 

102  go  to  (130,131,132,133,200,200),mm 

103  go  to  (140,141,142,143,200,200) , mm 

104  go  to  (150,151,152,153,200,200) , mm 

105  go  to  (160,161,162,163,200,200) , mm 

200  write  (60,201) l,m,a,b,t 

201  format  (//2i5, 3fl7 . 7, 15h  error  in  ovlap  ) 
stop 

c . 00 

110  ovlap-l.dO 
go  to  300 

c . 01 

111  ovlap-b 
go  to  300 

c . 02 

112  ovlap-b*b+0 . 5d0*t 
go  to  300 

c . 03 

113  ovlap»b* (b*b+l . 5d0*t) 
go  to  300 

c . 10 

120  ovlap-a 
go  to  300 

c . 11 

121  ovlap-a*b+0 . 5d0*t 
go  to  300 

c . 12 

122  ovlap-a*b*b+t* (b+0 . 5d0*a) 
go  to  300 

c . 13 

123  ovlap-b* <b* (b*a+l . 5d0*t) +1 . 5d0*a*t ) +0 . 75d0*t*t 
go  to  300 

c . 20 

130  ovlap«a*a+0 . 5d0*t 
go  to  300 

c . 21 

131  ovlap-a*a*b+t* (a+0 . 5d0*b) 
go  to  300 

c . 22 

132  ovlap-a*a*b*b+t* (0 . 5d0* (a*a+b*b) +2 . d0*a*b+0 . 75d0*t ) 
go  to  300 

c . 23 
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133  aa-a*a 
tt-t*t 

ovlap-b* (b* (b* (aa+0 . 5d0*t) +3 . dO*a*t ) +1 . 5d0*aa*t+2 . 25d0*tt) +1 . 5d0*a 
x*tt 

go  to  300 
c . 30 

140  ovlap-a* (a*a+l . 5d0*t) 
go  to  300 

c . 31 

141  ovlap-a* (a* (a*b+l . 5d0*t) +1.5d0*b*t)  +0.75d0*t*t 
go  to  300 

c . 32 

142  bb-b*b 
tt-t*t 

ovlap-a* (a* (a* <bb+0 . 5d0*t) +3 . d0*b*t ) +1 . 5d0*bb*t+2 . 25d0*tt) +1 . 5d0*b 
x*tt 

go  to  300 
c . 33 

143  ab-a*b 

abab-a*a+3 . d0*ab+b*b 

ovlap-ab* (ab*ab+l . 5d0*t*abab) +t*t* (2 . 25d0*abab+l . 875d0*t) 
go  to  300 
c . 40 

15C  ovlap«a*a* (a*a+3 .d0*t) +0 . 75d0*t*t 
go  to  300 
c . 41 

151  ovlap-a* (a* (a* (a*b+2 . d0*t) +3 .d0*b*t ) +3 . d0*t*t) +0 . 75d0*b*t*t 
go  to  300 

c . 42 

152  bb=b*b 
tt-t*t 

ovlap=a* (a* (a* (a* (bb+0 . 5d0*t) +4 . d0*b*t) +3 .d0*bb*t+4 . 5d0*tt) +6.d0*b 
x*tt)+  tt*(0.75d0*bb+1.875d0*t) 
go  to  300 
c . 43 

153  t2=-t*t 
b2=b*b 

ovlap=a* (a* (a* (a* (b* (b2+1.5d0*t) )+3.d0*t* (2.d0*b2+t) )+3.d0*b*t* (b2 
x+4 . 5d0*t) ) +t2* (9 . d0*b2+7 . 5d0*t) ) +b*t2* (0 . 75d0*b2  +  5 . 625d0*t) 
go  to  300 

c . 50 

16C  a2=a*a 

ovlap-a* (5.d0*t*  (0 . 75d0*t+a2) +a2*a2) 
go  to  300 
c . 51 

161  t2«t*t 

ovlap-a* (a* (a* (a* (a*b+2 . 5d0*t) +5 . d0*b*t) +7 . 5d0*t2 ) +3 . 75d0*b*t2) +1 . 
x875d0*t*t2 
go  to  300 
c . 52 

162  t2«t*t 
b2-b*b 

ovlap-a* (a*(a*(a*(a*(0. 5d0*t+b2) +5 . d0*b*t) +5 . d0*b2*t+7 . 5d0*t2) + 
x  15.d0*b*t2)+t2* (3.75d0*b2+9. 375d0*t) )+3. 75d0*b*t*t2 

go  to  300 
c . 53 

163  u-t/2 .d0 
u2-u*u 
a2-a*a 
a4-a2*a2 
b2-b*b 
ab-a*b 

ovlap-ab*a4*b2+u* (3 . d0*ab*a4+15 .d0*a4*b2+10 .d0*a2*b2*ab) +3 . d0*u2* ( 
x  5.d0*a4+30.d0*a2*ab+30.d0*a2*b2+5.d0*ab*b2)+15.d0*u*u2* (10 
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x.d0*a2+15.d0*ab+  3 .d0*b2) +105 .d0*u2*u2 

300  continue 
return 
end 

double  precision  function  fmch  (  m,  x,y) 
implicit  double  precision (a-h, o-z) 
c  this  subroutine  evaluates  the  integral  from  0  to  1  of 

c  (u*M2*m)  )  *  expf  <-x*  (u**2) ) 

c  changes  in  precision  and  accuracy  made  jan.1986  by 
c  donald  r.beck,mtu.  aside  from  changes  in  cutoffs 
c  to  l.d-15,and  accuracy  of  pi4,and  extension  of 
c  first  do  loop,  argument  at  which  go  to  asymptotic 

c  form  was  changed  from  10  to  20.  the  asympotic 

c  series  will  not  converge  to  l.d-15  with  arguments 
c  between  10  and  20, and  so  these  must  be  done  via 
c  the  small  argument  expression, 
c  note  that  the  problems  of  underflow/overflow 
c  associated  with  single  precision  (hardware) 
c  machines  like  the  vax  have  only  been  removed 
c  for  the  call  from  vints.  calls  from  savrge 
c  and  spdfnt  have  still  to  be  explored. 

common/comfmch/pi4 , apO , apl , ap2 , ap3, ap4 , apS, ap6 
if  (x-20.d0) 10, 10,20 

10  a*m 
a«a+0 . 5d0 
term«l . OdO/a 
ptlsum=term 
do  11  i-2,100 
a=a+l . OdO 
term=term*x/a 
ptlsum=ptlsum+tenn 

if  (term/ptlsum-1 .d-15) 12, 11,11 

11  continue 
write  (6,999)m,x 
stop 

12  fmch»0 . 5d0*ptlsum*y 
go  to  150 

20  a=m 
b»a+0 . 5d0 

a=a-0 . 5d0 
xd=l .dO/x 

approx*pi4*dsqrt (xd) 
if  (m) 21,23,21 

21  do  22  i“l,m 
b-b-l.OdO 

22  approx*approx*b 

23  f imult-0 . 5d0*y*xd 
ptlsum»0.d0 

ap0*approx 
apl=ap0*xd 
ap2»apl*xd 
ap3»ap2*xd 
ap4«ap3*xd 
ap5=ap4*xd 
ap6«ap5*xd 
approx-approx*xd**m 
c  approx»ap6  only  if  m»6 

c  the  call  from  vints  used  to  multiply  approx  by  x**n 
c  (1  .le.  n  .le.  m)  in  the  recursion  formula, 
c  by  using  apl  through  ap6  for  large  arguments, we  have 
c  actually  factored  this  multiplication  into  fmch 
c  it  will  only  be  used  by  vints  if  y»0.do  (i.e. 
c  x  . ge . 8  5 ) 

c  the  returned  value  of  fmch  is  the  same  as  it  always 
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c  note  the  fmch  is  used  in  savrge  and  spdfnt.  the  usage 
c  in  these  routines  has  not  been  modified  as  of  yet. 
if  (fimult) 421,25,421 
421  continue 

fiprop-fimult /approx 
term-1 . OdO 
ptlsum-term 
notrms-x 
notrms»notrms+m 
do  24  i-2,notrms 
term«term*a*xd 
ptlsum-ptlsum+term 

if  (dabs (term*fiprop/ptlsum) -l.d-15)25,25,24 

24  a-a-l.OdO 
write  (6,999)m,x 
stop 

25  fmch-approx-f imult*ptlsum 
15C  return 

999  format  (24h  no  convergence  for  fmch,  i6,  el6.9) 
end 

subroutine  rdinpt  (nfmx, ngmx, ncmx, ntmx,maxtyp, nbfns, ngaus, noc, 
5  nlist, c, eta, number, ncntr, ntype, kcntr, ktype, 

$  nfirst , nlast ,  mlist , icntr, vlist , itype, nr, non) 

c 

c . icon  definitions 

c 

c  icon(l)  -  calculate 

c  0  =  le  and  2e 

c  1  =  le  only 

c  2  =  le  and  change  some  2e  (mlist) 

c  3  -  le  and  copy  2e 

c  4  -  le,  copy.  2e  and  add  bfns 

c  5  -  le,  copy  2e  and  restart  2e 

c 

c  icon  (2)  -  tape  in 

c  0  =  none 

c  1  =  polyatom 

c  2  »  polyijlk 

c  3  =  polypair 

c  4  *  polypair  +  ijlk 

c  icon (3)  -  normalize 

c  0  -  yes 

c  1  -  no 

c 

c  icon  (4)  -  check  symmetry 

c  0  -  yes 

c  1  -  no 

c 

implicit  double  precision (a-h, o-z) 
c 

c  valid  combinations  of  icon(l)  and  icon(2) 

c 

c  icon(2) 

c  0  12  3  4 

c  icon(l) 

c  0  x  x  x 

c  lx 

c  2  xx 

c  3  x  x  x  x 

c  4  xx 

c  5  x 
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character* Stlopot 

dimension  c(ngmx),  eta (ngmx, 5) ,  number (nfmx) ,  ncntr(nfmx) 

$  ,  ntype <nfmx) ,  nfirst (nfmx) ,  nlast(nfmx),  mlist (nfmx) 

S  ,  icntr(ncmx),  vlist (ncmx, 4) ,  itype (ntmx) ,  nr(ntmx,3) 

$  ,  kcntr (nfmx) , ktype (nfmx) 

common/ergnuc/energy 
common/lptyp/tlopot (1024) 
common/ioind/icon (10) , ifile2 
common/labels /ilbl (18) ,  ilab (18) 
common/namtap/nitape,  lstnam, notape, intnam 
common/nmbrs/pi,piterm,pitern, acrcy, scale, icanon 
equivalence (iconl,  icon (1) ) ,  (icon2,  icon (2) ) ,  (icon3, icon  (3) ) , 

2  (icon4, icon (4) ) , (icon9, icon (9) ) , ( iconl 0, icon (10) ) 
dimension  neon (30) 
dimension  wzero (6) , zro (6) 

data  ncon/1, 1,1,0,  0,1, 0,0,  0,0, 0,1, 1,0,  0,1, 1,1, 1,1, 0,1, 1,0, 0,0, 1,0, 
*  0,0/ 

data  iblnk/4h  / 

data  blank/4h  / 

data  i jlk, jkpr/' i jlk' ,' jkpr' / 

data  zro/'  zer','o  co','ef  s','et  t','o  on','e  '/ 

nlist-0 

icanon«2 

ierr**0 

i-2 

c  read  and  print  the  problem  label. 

read(5,930) (ilbl (ii) , ii-1, 18) 
c  read  and  print  the  control  options, 
read  (5, 900) icon, ifile2 
if ile2»l 

if (iconl . eq. 2) icon9-l 

if (iconl . It . 0 . or . iconl .gt . 5) got o7 10 

if (icon2 . It . 0 . or . icon2 .gt . 4) goto710 

if (neon (5*iconl+icon2+l ) .eq. 0) goto710 

iconl0-icon2 

if (iconl . ge. 4) iconl 0-0 

ilbl (18) -iblnk 

if (iconl . ne . 4 . and. icon2 . eq. 2) ilbl ( 18) -i jlk 
if (icon2 . ge . 3) ilbl (18) « jkpr 
write (60, 931) (ilbl (ii) , ii«l, 18) 
write  (60, 901) icon 
go  to  670 
710  ierr-ierr+1 

write (60, 931) (ilbl (ii) , ii»l, 18) 
write  (60, 901) icon 
write  (60,  935) 

c  read  and  print  the  center  coordinates. 

670  write  (60, 671) 

write (60, 672) nfmx, ngmx 
write (60, 673) ncmx 
write (60, 674) 

671  format (//5x, 20hprogram  limitations  ) 

672  format (/5x, 2 5hmax  no  basis  functions-  ,i4 

x  /5x,28hmax  no  gaussian  primitives-  ,i4) 

673  format (/5x, 15hmax  no  centers-  ,i4) 

674  format  (/5x, ' s, p, d, f  type  gaussians  only') 
read  (5, 918) non, nac 

write  (60, 904) non, nac 
noc-non+nac 

i f (non . le . ncmx . and . noc . le . ncmx) got o60 
ierr  »ierr+l 
write  (60, 940) 
non-minO (non, ncmx) 
nac-minO (nac, ncmx-non) 

JO 
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60  write (60, 905) 
do  70i-l,non 

read  (5,  906)  icntr  (i) ,  (vlist  (i,  j)  ,  j-1, 4)  ,  izz,  tlopot  (i) 
write  (60,907) icntr (i) , (vlist (i, j) , j-1, 4) , tlopot (i) 

70  continue 

if  (  nac. le . 0) goto90 
k  -  non+1 
1-non+nac 
write (60,908) 
do  80i-k,l 

read  (5,  906) icntr  (i) ,  (vlist (i,  j) , j-1, 4) 
write  (60, 907) icntr (i) , (vlist (i, j) , j-1, 4) 

80  continue 

c  read  and  check  the  basis  functions. 

90  read  (5, 918) ngaus, nbfns 
write  (60, 909) ngaus, nbfns 
iq»3 

if  (ngaus . le . ngmx) gotolOO 
ierr  *ierr+l 
write  (60,941) 
ngaus  -ngmx 

100  if  (  nbfns . le . nfmx) gotollO 
ierr  -ierr+1 
write  (60,942) 
nbfns  -nfmx 

110  read  (5, 915) (number (i) , i-1, nbfns) 
if  (  nbfns. ne. ngaus) gotoll4 
do  112i-l, nbfns 
112  number(i)»l 
114  nfirst (1) -1 

if (number(l) ,eq. 0) number (1 ) =1 
nlast (1) -number (1) 
do  120i-2,nbfn3 

nfirst (i) -nlast (i-1) +1 
if (number (i) . eq. 0) number (i) *1 
120  nlast (i) -nlast (i-1) +number (i) 

if  (  nlast (nbfns) . eq. ngaus) gotol30 
ierr  -ierr+1 
write  (60,943) 

130  maxtyp-1 
i  -  0 

do  300  jo-1, nbfns 
isave  -0 

isf  »  number (jo) 
do  290k-l,isf 
i  »  i+1 

if  (  isave . ne . 0) gotol60 
read  (5,910)  kcnt, ktyp, inc, izz, expnt , c  (i) 
kcntr ( jo) -kcnt 
ktype( jo) -ktyp 
if  (  inc . eq. 0) gotol70 
if  (  inc.gt.O.and.inc.lt. jo)gotol40 
ierr  -ierr+1 

write  (60,944)  jo, kcnt, ktyp, inc 
go  to  300 

140  if  (  number (inc) . eq. isf ) gotol50 

ierr  -ierr+1 
write  (60, 945) jo, inc 
isf  -  number(inc) 


150 

ii  - 

nfirst (inc) 

isave 

-1 

160 

c (i)  -c (ii) 

expnt 

-eta (ii, 4) 

ii  - 

ii+1 

/  0  3 
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170  if  (  expnt . ne . 0 .d0) gotol80 

ierr  -ierr+1 
write  (60,946) 

180  do  6055mm-l,6 

6055  wzero (mm) "blank 

if (c (i) . ne . 0 . dO) gotol90 
c (i)  -l.dO 
do  6056mm-l,6 

6056  wzero (mm) -zro (mm) 

190  if  (  k . eq. 1 . or . ierr . ne . 0) goto230 

if (kcnt . eq. icntr ( ja) )  go  to  210 
ierr  -ierr+1 
write  (60,948)jo,k 

210  if (ktyp. eq. itype ( jb) ) goto270 

ierr  -ierr+1 
write  (60,949) jo, k 
go  to  270 

230  do  240jt-l,noc 

ja  -  jt 

if (kcnt . eq. icntr ( ja) )  go  to  250 
240  continue 

ierr  -ierr+1 
write  (60, 950) jo 
250  do  260jt=l,ntmx 

jb  -  jt 

if (ktyp. eq. itype ( jb) )  go  to  270 
260  continue 

ierr  -ierr+1 
write  (60, 951) jo 
270  ncntr(jo)-ja 

ntype ( jo) - jb 

write (60,1911)i,jo,k,  kcnt, ktyp, expnt, c (i) ,  (wzero (m) ,m-l, 6) 
do  280m=l,3 

280  eta (i,m) -vlist ( ja,m) 

eta (i, 4) -expnt 

if  (  jb.gt .maxtyp)maxtyp= jb 
290  continue 

300  continue 

read  (5, 912) acrcy, scale 

if  (  acrcy . eq. 0 . dC) acrcy-1 . 0d-10 

if  (  scale. eq. O.dO) scale-1 . OdO 

scale  -scale*acrcy 

write  (60, 913) acrcy, scale 

if  (  icon (9) . ne . 1) goto320 

read  (5,918)nlist 

read  (5, 918)  (mlist (i)  ,  i»l , nlist ) 

write  (60, 914) nlist, (mlist (i) , i»l, nlist) 

do  310i-l, nlist 

c  error  in  polyatomin  next  statement-fixed  7/31/69-wyh 
c  (nbfn)  replaced  by  (nbfns) 

if  (  mlist (i) .gt . 0 . and. mlist (i) . le . nbfns) goto310 
ierr  -ierr+1 
write  (60,954) 

310  continue 

320  if  (  ierr.eq. 0)goto330 
write  (60,952)ierr 
stop 

c  are  the  basis  functions  in  standard  order. 

330  do  340 jo-2, nbfns 

if  (  ntype (jo) .ge. ntype ( jo-1 )) goto340 
icanon-1 
write  (60,922) 
go  to  400 
340  continue 
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write  (60,923) 

400  continue 

c  normalize  the  primitive  functions 
do  420i-l,nbfns 


ityp 

-ntype (i) 

1  - 

nr (ityp, 1) 

m  - 

nr (ityp, 2) 

n  - 

nr (ityp, 3) 

is  * 

nfirst  (i) 

if  - 

nlast (i) 

do 

410ii=is, if 

t  -  0 . 5d0/eta (ii, 4) 

soo  *  pitern*t**l . 5d0 
tl  *  ovlap (1, 1, 0 . OdO, 0 . OdO, t) 
t2  -  ovlap (m, m, 0 . OdO, 0 . OdO, t ) 
t3  -  ovlap (n, n, 0 . OdO, 0 . OdO, t) 
gii  *  soo*tl*t2*t3 
410  eta (ii,  5) -1 . OdO/dsqrt (gii ) 

420  continue 

if  (  icon (3) . eq. 1 ) gotoSSO 
c  renormalize  the  basis  functions, 
write  (60,916) 
do  540i»l,nbfns 
ityp  -ntype (i) 

1  -  nr (ityp, 1 ) 
m  »  nr (ityp, 2) 
n  -  nr (ityp, 3) 
is  -  nfirst(i) 
if  -  nlast(i) 
prtint-0 .dO 
do  520ii-is,if 
do  510jj-is,if 

t  =  1 . OdO/ (eta  (ii, 4) +eta  ( j j, 4)  ) 

soo  -  pitern* (t**l . 5d0) *eta (ii, 5) *eta  ( j j,  5) 
tl  =  ovlap (1, 1, 0 . OdO, 0 . OdO, t ) 
t2  »  ovlap (m, m, 0 . OdO, 0 . OdO,  t ) 
t3  *  ovlap (n, n, 0 . OdO, 0 . OdO, t) 

510  prtint=prtint+c (ii)*c(jj)*soo*tl*t2*t3 

520  continue 

prtint-1 . OdO/dsqrt (prtint) 
do  530k-is,if 

c(k)  -c(k)*prtint 
ij  =  k-is+1 

write  (60,917)k,i,ij, ncntr (i) ,  ntype (i) , nr (ityp, 1 ) , nr (ityp, 2 ) 
$  , nr (ityp, 3) , eta (k, 4) , c (k) 

530  continue 

540  continue 

550  do  560k«l,ngaus 
560  eta  (k,  5)  -eta  (k,  5)  *c  (k) 

c  calculate  the  nuclear  repulsion  energy. 
energy-0 . dO 

if  (  noc. le . 1) goto630 
write  (60,919) 
nonml  -non-1 
do  620i-l, nonml 
ipl  -  i+1 
do  610j»ipl,non 

rij  -  sqrt ( (vlist (i, 1) -vlist ( j,  1) ) **2+ (vlist  (i, 2) 
x  -  vlist  ( j, 2) ) **2  +  (vlist(i,3)  -  vlist ( j, 3) ) **2  ) 

rija  -ri j*0 . 52917d0 

if (non. le . 20) write (60,920) icntr (i) , icntr ( j) , rij, rija 
if (ri j . It . 1 . d-16) go  to  899 
610  energy-energy+vlist (i, 4) *vlist ( j, 4) /rij 

620  continue 
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630  write  (60, 921) energy 
return 

899  write  (60,955)i,j 
stop 

900  format  {  lli5  ) 

901  format  {  /  3x,  32hprogram  control  options  ...  ,  10i5  ) 

904  format  (  /  3x,  20hnumber  of  nuclei  =  ,  i5,  15x, 

x  33hnumber  of  additional  centers  «,  i5  ) 

905  format  (  /  10x,  26h*  *  nuclear  centers  *  *  //3x,  6hcenter,  18x, 
x  llhcoordinates,  21x,  6hcharge, 7x, ' local  potential',/) 

906  format (a4, 6x, 4f 12 . 8, i2, a8) 

907  format  (3x,  a4,  6x,  3fl2.8,  6x,  fl2.8  ,5x,a8) 

908  format  (  /  10x,  29h*  *  additional  centers  *  *  /  3x,  6hcenter, 

x  18x,  12hcoordinates  /  ) 

909  format  (  //  lOx,  44h*  *  gaussian  function  specifications  *  * 

x  //3x, 31hnumber  of  primitive  gaussians  =  ,i5  /  3x, 

x  31hnumber  of  basis  functions  =,  i5  //3x, 8hgaussian,  3x, 

x  8hfunction,  3x,  9hcomponent,  3x,  6hcenter,  4x,  4htype,  6x, 

x  8hexponent,  6x,  llhcoef f icient  ) 

910  format  (  a4,  6x,  a4,  i3,  i3,  2fl2.0  ) 

911  format  (3 (3x,  i5,  3x) ,  4x, a4, 5x, a4 , 2f 15 . 7  ) 

1911  format(  3(3x,i5,3x),  4x, a4 , 5x, a4 , 2f 15 . 7, 2x, 6a4 ) 

912  format (2dl5. 8) 

913  format (//, 3x, ' dont  calculate  two-electron  integrals',/, 

1'  if  the  prefactor  is  less  than' , el5 . 5, //, 3x, 

2' do  not  write  them  to  disc  if  they  are  less  than',el5.5) 

914  format  (  //  3x, 

x  'integrals  which  involve  the  '  ,i5, 

xlOx,  24i4) 

915  format  (  36i2  ) 

916  format  (lhl,10x,  44h*  *  renormalize  the  basis  functions  *  * 

x  //  3x,  8hgaussian,  3x,  8hfunction,  3x,  9hcomponent,  3x, 

x  6hcenter,  4x,  4htype,  5x,  lhl,  5x,  lhm,  5x,  lhn,  6x, 
x  8hexponent,  6x,  llhcoef f icient  ) 

917  format  (  3x, i5,  6x, i5,  6x,  i4, 5x,  i6, 4x, i6, lx, 3i6, 2x, 2f 15. 7  ) 

918  format  (  24i3  ) 

919  format  (  //  lOx,  36hinternuclear  distances  from  geometry  // 

x  8x, 8h  centers, llx,  4ha.u.,  lOx,  2ha.  ) 

920  format  (  5x,  a4,  3h  -  ,  a4,  2fl4.6  ) 

921  format  (  //  3x,  27hnuclear  repulsion  energy  «  ,  fl4.8,  6h  a.u.) 

922  format  (  /3x,46hthe  basis  functions  are  not  in  standard  order  ) 

923  format  (  /3x,49hthe  basis  functions  are  listed  in  standard  order  ) 

930  format (18a4) 

931  format (lhl//5x, 18a4  //) 


935 

format (//10x, ' **  incompatible  icon(l)  and 

icon (2)  paramete 

2  **'/) 

940 

format 

( 

//  lOx, 26h** 

too  many 

centers  ** 

/  ) 

941 

format 

( 

//  lOx, 29h** 

too  many 

primitives 

**  /  ) 

942 

format 

( 

//  lOx, 28h** 

too  many 

function  **  /  ) 

943 

format 

( 

//  lOx) 

944 

format 

( 

//  lOx, 

xi4, 6x, . 

a4 

,a4,i4, 

x  4h 

**  /  ) 

945 

format 

( 

//  lOx, 37h** 

number  of 

primitives  in  functions, i5. 

x  4h 

and, i5,15h  not 

equal  ** 

/  ) 

946 

format 

( 

//  lOx, 22h** 

zero  exponent  **  /  ) 

947 

format 

( 

lOx, 39h** 

zero  coefficient  set 

to  one  **  ) 

948 

format 

( 

//  10x,i5,5x, 

xi4/  ) 

949 

format 

< 

//  lOx,  35h** 

types  not 

same  for 

function, i5, 5x, 

x  lOhprimitive  ,i4,4h  **  /  ) 

950 

format 

( 

//  lOx,  36h** 

undefined 

center  for 

function, i5, 4h  ’ 

951 

format 

( 

//  lOx, 34h** 

unallowed 

type  for 

function, i5, 4h  **, 

952  format (//10x, i3, '  error (s) .  another  run  for  the  seucr 
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2man  **'/) 

954  format  (  //  10x,38h**  undefined  function  in  mlist  **  /  ) 
955  format (lx, ' center  ',i3,2x,'and  center  ' , i3, 2x, ' have  identical 
1  coordinates' ) 
end 

subroutine  gints  (ntype, nr, nfirst , nlast, eta, nfmx, 

$  ntmx, ninmax, ngmx, nbfns) 

implicit  double  precision  (a-h,o-z) 
integer *2iil (1024) ,  jjl (1024)  ,  itgl (1024) 

dimension  ntype (nfmx) , eta (ngmx, 5) , nfirst (nfmx) , nlast (nfmx) , 

1  valint (1024) , nr (ntmx, 3) 
commonvalint 

dimension  s (8256) , char (3) 
common/ioind/icon (10) 

common/namtap/nitape,  lstnam,  notape,  intnam 
common/nmbrs/pi,  pi term, pi tern, acrcy , scale, icanon 
data  char/lh  ,lh+,lh-/ 
ierr  -0 
nokk-0 

if (icon (2) .ge.3)nokk=l 
if (nokk) 3, 3, 1 
1  kka-0 
3  nrcnt-0 

if  (  icon (4) .eq. 1) gotolO 
write  (60,992) 
index  -nbfns* (nbfns+1 ) /2 
do  4  i-1,  index 
4  s (i)  -O.dO 

10  if (nokk) 11,12, 11 

11  read (nit ape)  nints,  1st red, iil, jjl, itgl 

go  to  13 

12  read(nitape) nints, lstrcd, iil, jjl, itgl 

13  nrcnt-nrcnt+1 

if (nints . le . 0) gotol915 

if  (  nints . le . 0 . or . nints . gt . ninmax) goto800 
do  914m»l, nints 
i-iil (m) 

j-j jl <m) 

itag»itgl (m) 

if  (  icon (4) .eq. 1 ) goto550 
index**  (i*  (i-1)  )  /2+ j 
s (index) «1 ,d0 
go  to  403 
550  continue 

if  (itag-1) 403, 402, 408 
408  valint (m) --prvint 
go  to  916 

402  valint (m) -prvint 
go  to  916 

403  valint (m) -0 . dO 
ityp-ntype (i) 
jtyp-ntype ( j) 

11- nr (ityp, 1) 

12- nr ( jtyp, 1) 
ml»nr (ityp, 2) 
m2 -nr ( jtyp, 2) 
nl-nr (ityp, 3) 
n2«nr ( jtyp, 3) 
is-nf irst (i) 
if-nlast (i) 
js-nfirst ( j) 
jf-nlast ( j) 

do  635ii-is, if 
a-eta  (ii, 4) 
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do  1635jj-js,jf 
b-eta( j j,4) 
t-l.dO/ (a+b) 

pi- (a*eta (ii, 1) +b*eta ( j j, 1) ) *t 
p2- (a*eta (ii, 2) +b*eta ( j j, 2) ) *t 
p3- <a*eta (ii, 3) +b*eta ( j j, 3) ) *t 
abl-eta (ii, 1) -eta  ( j j, 1) 
ab2-eta (ii, 2) -eta ( j j, 2) 
ab3-eta (ii, 3) -eta ( j j, 3) 
distab-abl*abl+ab2*ab2+ab3*ab3 

soo- (pitern*t**l . 5d0) *exp (-a*b*distab*t ) *eta (ii, 5) *eta ( j j, 5) 

pax-pl -eta ( ii , 1 ) 

pbx-pl-eta ( j j, 1) 

pay«p2-eta (ii, 2) 

pby-p2-eta ( j j, 2) 

paz-p3-eta (ii, 3) 

pbz*p3-eta ( j j, 3) 

tl-ovlap (11 , 12, pax, pbx, t) 

t2-ovlap(ml,m2,pay,pby, t) 

t3»ovlap (nl, n2, paz, pbz,  t) 

1635  valint (m) -valint (m) +soo*tl*t2*t3 

635  continue 

if  (  icon(4) .eq. 1 ) gotoSlO 
if  (itag-1) 510, 511, 512 

511  dif f-valint (m) -prvint 
go  to  513 

512  dif f-valint (m) +prvint 

513  if  (dabs(diff) . It . 1 . 0d-06) goto916 

write  (60,520) ikeep, jkeep, prvint,  i,  j, char (itag+1)  ,  valint (m) 
ierr  =ierr+l 
go  to  916 

510  prvint-valint (m) 
ikeep=i 
jkeep- j 

916  continue 

914  continue 

1915  if (nokk) 1916, 1917, 1916 

1916  write (notape) nints, 1st red, iil, jjl, itgl , valint 
go  to  1918 

1917  write (notape) nints, 1st red, iil, jjl, itgl, valint 

1918  if (1st red) 915, 10, 915 

915  if  (  icon (4) .eq. 1) return 
do  581i=l,nbfns 
do  580j»l,i 
index- (i* ( i— 1 ) ) /2+ j 
if  (s (index) .ne. 0 .d0) goto580 
rawint-0 .d0 
ityp-ntype  <i) 
jtyp-ntype ( j) 

11- nr (ityp, 1) 

12- nr ( jtyp, 1 ) 
ml -nr (ityp, 2) 
m2«nr ( jtyp, 2) 
nl-nr (ityp, 3) 
n2-nr ( jtyp, 3) 
is-nf irst (i) 
if-nlast (i) 
js-nfirst ( j) 
jf-nlast ( j) 

do  536ii-is,if 
a-eta (ii, 4) 
do  535 j j-js, jf 
b-eta ( j j, 4) 
t-1 . d0/ (a+b) 
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pi- (a*eta (ii, 1) +b*eta  ( j j, 1) ) *t 
p2- (a*eta (ii, 2) +b*eta ( j j, 2) ) *t 
p3- (a*eta (ii, 3) +b*eta ( j j, 3) ) *t 
abl-eta (ii, 1) -eta  ( j  j, 1) 
ab2«eta (ii, 2) -eta ( j j, 2) 
ab3-eta (ii, 3) -eta ( j  j, 3) 
distab-abl*abl+ab2*ab2+ab3*ab3 

soo- (pitern*t**l . 5d0) *exp (-a*b*distab*t ) *eta (ii, 5) *eta  ( j  j,  5) 

pax-pl-eta (ii,  1 ) 

pbx-pl-eta ( j j,  1) 

pay-p2-eta (ii, 2) 

pby»p2-eta ( j j,2) 

paz=p3-eta (ii, 3) 

pbz«=p3-eta ( j j, 3) 

tl-ovlap (11, 12, pax, pbx, t) 

t2-ovlap (ml, m2, pay, pby, t) 

t3=ovlap (nl , n2, paz, pbz, t ) 

535  rawint-rawint+soo*tl*t2*t3 

536  continue 

if  (dabs  (rawint)  . It . 1 . 0d-07 ) goto580 
ierr  -ierr+1 

write  (60, 585) i, j, rawint 

580  continue 

581  continue 

if  (  ierr. eq. 0) return 
write  (60,993)ierr 
stop 

800  write  (60, 994) nrcnt, nints 
stop 

520  format  (3x,  '  symmetry  error' , 5x, ' i  =  ' , i3, 3x, ' j*' , i3, ' prvint-' , f 14 . 

x8, 5x, 2hi-, i3, 3x,  2h j-, i3, 3x, 4htag=,  al, 3x, 9hintegral=, fl4 . 8) 

585  format  (3x,'zero  integral',  2i4 , 3x, ' actually  is  '  ,fl4.8) 

992  format (9x,  '  test  symmetry'//) 

993  format ( /3x,  37h**  gints  cannot  continue  ,  ierr  =,i5,4h  **) 

994  format (/3x, i5, 
xilO) 

end 

subroutine  tints  (ntype, nr, nf irst,  nlast, eta, nfmx, 

$  ntmx, ninmax, ngmx) 

implicit  double  precision  (a-h,o-z) 
integer* 2iil (1024) , jjl (1024) ,itgl (1024) 

dimension  ntype (nfmx) , eta (ngmx, 5) , nfirst (nfmx) , nlast (nfmx) , 

1  valint (1024) , nr (ntmx,  3) 
commonvalint 
common/ioind/icon (10) 

common/namtap/nitape, lstnam, notape, intnam 
common/nmbrs/pi, piterm, pitern, acrcy, scale, icanon 
nokk-0 

if (icon (2) . ge. 3) nokk=l 
if (nokk) 3,3,1 

1  do  2  i-1,1024 
iil (i) -0 

jjl (i) -0 

2  itgl(i)-0 

3  nrcnt-0 

10  if (nokk) 11, 12, 11 

11  read (nit ape) nints, 1st red, iil, j jl, itgl 
go  to  13 

12  read (nit ape) nints, 1st red, iil ,  jjl,  itgl 

13  nrcnt-nrcnt+1 

if (nints. le. 0) gotol915 

if  (  nints . le . 0 . or . nints . gt . ninmax) goto800 
do  916m-l, nints 
i-iil (m) 

I  of 
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j- j  jl  (m) 

itag-itgl (m) 

if  (itag-1) 403, 402, 408 

408  valint (m) --prvint 
go  to  916 

402  valint <m) -prvint 
go  to  916 

403  valint (m) -0 .d0 
ityp-ntype (i) 
jtyp-ntype ( j) 

11- nr (ityp, 1) 

12- nr ( jtyp, 1) 
nu-nr  (ityp,  2) 
m2-nr ( jtyp, 2) 
nl-nr (ityp, 3) 
n2=nr ( jtyp, 3) 
is-nfirst (i) 
if-nlast (i) 
js=nfirst ( j) 
jf-nlast ( j) 

do  635ii=is,if 
a=eta  (ii, 4) 
do  1635 j j=js, jf 
b=eta(j j,4) 
t-l.d0/ (a+b) 

pi- (a*eta (ii, 1) +b*eta ( j  j, 1 ) ) *t 
p2- (a*eta (ii, 2) +b*eta ( j j, 2) ) *t 
p3=(a*eta(ii,3)+b*eta(jj,3) )*c 
abl-eta (ii, 1) -eta ( j j, 1) 
ab2»eta (ii, 2) -eta  ( j j, 2) 
ab3-eta (ii, 3) -eta  ( j j, 3) 
distab=abl*abl+ab2*ab2+ab3*ab3 

300- (pitern*t**l . 5d0) *exp (-a*b’distab*t) *eta (ii, 5) *eta ( j j, 5) 

pax-pl-eta (ii, 1 ) 

pbx-pl-eta ( j j, 1) 

pay=p2-eta (ii, 2) 

pby»p2-eta ( j  j , 2 ) 

paz-p3-eta (ii, 3) 

pbz-p3-eta ( j  j ,  3) 

tl=ovlap (11, 12,pax,pbx, t) 

t2=ovlap(ml,m2,pay,pby,  t) 

t3-ovlap (nl, n2, paz, pbz, t ) 

sl-ovlap (12+2, 11, pbx, pax, t ) 

s2=ovlap (m2+2,ml, pby,  pay,  t ) 

s3»ovlap (n2+2, nl, pbz, paz, t) 

part-2* (12+m2+n2) +3 

tke-b* (part*tl*t2*t3-2.d0*b» (sl*t2*t3+tl*s2*t3+tl*t2*s3) ) 
if  (12-1)190,190,191 

191  part- (12* (12-1) ) /2 
sl-ovlap (11 , 12-2, pax, pbx, t ) 
tke=tke-part*sl*t2*t3 

190  if  (m2-l) 192,192,193 

193  part- (m2* (m2-l) ) /2 
s2-ovlap(ml,m2-2,pay,pby, t) 
tke-tke-part*tl*a2*t3 

192  if  (n2-l) 194,194,195 

195  part- (n2* (n2-l) ) /2 

s3-ovlap (nl , n2-2 , paz , pbz , t ) 
tke-tke-part*tl*t2*s3 

194  continue 

1635  valint (m) -valint (m) +soo*tke 

635  continue 

prvint-valint (m) 

916  continue 
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1915  if  (noJck)  1916, 1917, 1916 

1916  write (notape) nints, 1st red, iil, j jl, itgl, valint 
go  to  1918 

1917  write (notape) nints, 1st red, iil, j jl, itgl, valint 

1918  if (1st red) 915,10,915 
915  return 

800  write (60, 992) nrent, nints 
stop 

992  format  (/3x, '  **  tape  read  error  ir.  tints  nrent  **',i5, 
x  llh  ,  nints  -,il0,4h  **  ) 

end 

subroutine  dawtab 

implicit  double  precision  (a-h,o-z) 
c  dawson  function  generation 
common/dawson/daw (1000) 
c  errfun  generation 

c  y0=err (x) ,  yl=exp <-x**2) , y2=-2*x*yl ,  yn+2=-2*x*yn+l-2*n*yn 

common/err fun/err (550 ) 
common/dawsf /aoi (50) 
a=0.0d0 
do  5  i-1,50 
a*a+l . OdO 
5  aoi (i) =1 . OdO/a 
daw (1 ) =0 . OdO 
h=0 . OldO 
nx=999 

h2hm=-h*h*2 . OdO 
x2hm=-h2hm 
do  100i=l,nx 
x2hm=x2hm+h2hm 
a0=daw (i) 
al=h+x2hm*a0 

a2«(h2hm*a0+x2hm*al) *0.5d0 
a 3= (h2hm*al+x2hm*a2 ) *0 . 3333333333 3 33d0 
a4» (h2hm*a2+x2hm*a3) *0 . 25d0 
a5= (h2hm*a3+x2hm*a4 ) *0.2d0 
100  daw (i+1 ) =a0+al+a2+a3+a4+a5 
h=0 . OldO 
x=-0. OldO 
nx=549 

err (1 ) »0 . OdO 
hlo2  «h*0.5d0 

hlo3  *h*0 . 333333333 3333 3d0 

hlo4  -h*0.25d0 

hlo5  =h*0 . 20d0 

hlo6  -h/6 . OdO 

hlo7  -h/7.0d0 

do  200i=l,nx 

x=x+h 

x2=2 . 0d0*x 
ex2=exp (-x*x) 
x2m=-x2 
y0=err (i) 
yl-ex2 
y2»x2m*yl 

y3«x2m*y2-2 . 0d0*yl 
y4»x2m*y3-4 . 0d0*y2 
y5=x2m*y4-6 . 0d0*y3 

200  err (i+1) » (yO+h* (yl+hlo2* (y2+hlo3* (y3+hlo4* (y4+ 

#  hlo5*yj) ) ) ) ) 
return 
end 

subroutine  mints  (nlist , mli3t, nentr, ntype, eta, nf irst , nlast, 
$  nr , ntmx, ninmax. 
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$  ngmx, nsavmx,  naxtyp, ngaus) 

implicit  double  precision  (a-h,o-z) 

integer *2  mul  (1024) ,mu2  (1024),iil{1024)/jjl(1024)/ kkl (1024) , 

1  111(1024), 

1  itgl (1024)  ,  ii2  (1024) , jj2  (1024)  ,  kk2 (1024) , 112 (1024) , itg2  (1024) 
doubleprecision  s (259560) 
realM  spval(1024) 
real*8  dpval(1024) 

integer*2  iql (1024) , jql (1024)  ,  kql (1024) 

dimension  ncntr  (180) ,  ntype  (180),nfirstd80),nlast(180),mlist(180), 
xeta (ngmx, 5) , nr (ntmx, 3) , valint (1024 ) , vin (1024 ) 
common/ioind/icon (10) , if ile2 

common /namtap/ nit ape, lstnam,  notape, intnam, nctape 
common/nmbrs/pi, pi term, pitern,  acrcy, scale, i canon 
common/specs/icnt, jcnt, kcnt,  lent,  ityp, jtyp, ktyp, ltyp, is, js, ks, 

$  Is, if , jf , kf , If ,  nint , i, j , k, 1 

commonvalint, vin, iil, jjl,  kkl.  111, itgl , mul 
integer *2  iix(1024) ,jjx(1024) ,kkx(1024) 
icl»0 

c...  generate  f  integral  tables 
call  generf (maxtyp,  maxrng) 
write (60, 1420)maxtyp, maxrng 

c... compute  and  store  pre-exponential  factor  for  all  i,j  index  pairs, 
write  (60,1410) 

call  savrge (ngaus, eta, s, ngmx, nsavmx) 

icheck=0 

lrecnt=*0 

jcan»icanon-l 

nint  *0 

lzero  =0 

nzrlbl*0 

nzrint=0 

nintot=0 

nlbtot=0 

nogg»0 

if rst=0 

icntl=0 

ltestl*0 

c  if  ifile2=l,  then  labels  are  maintained  only  in  the  input  file, and 
c  only  the  unique  integrals  are  written  out  onto  the  old  combined  file, 
c  you  must  save  labels  output  then  for  the  gvb/uhf  runs 
c  this  option  may  be  incompatible  with  the  more  subtle  polyin  features, 
c  like  copy, etc. 

if (if ile2 . eq. 1 ) write (60, 2001 ) 

2001  format (///5x, ' separate  files  for  two  electron  integrals  and 
1  labels — beware' ) 
if (icon (2) .eq.2) nogg=l 
iopt-icon (9) 
if (icon (10) .eq. 0) goto20 
nitape*3 
nctape=2 
rewindnitape 
read  (nitape) 
read  (nitape) 
do  201kl=l , 3 
read  (nitape) 

202  read (nitape) ilab, ifml 
if (ifml .eq. 0) goto202 
201  continue 

read(nitape) 

20  if{  icon (1 ) . It . 4 ) goto30 
nint  -0 
nlbl-j 
lastrc-k 
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ii-iil (i) 
jj-jjKi) 

kk-kkl (i) 

11-111 (i) 
igg-itgl <i) 
muu-mul (i) 

write (60, 22) ii, j j, kk, 11 

22  format (lx, ' two  electron  integrals  restarted  at  ',4i5//) 
iml  -  i-1 
nlbl  -nlbl-iml 
do  38  i-1, nlbl 
j  -  i  +iml 
iil (i)-iil ( j) 
jjl(i)-jjl(j) 
kkl (i)-kkl ( j) 

111 (i)-lll (j) 
itgl (i) -itgl ( j) 
mul (i) =mul ( j) 

38  continue 

if (if ile2 . ne . 0) got o2 3 6 
13  i  =  1 

if (  itgl(i)-l)25,26,27 

26  itgl (i) -itgl (i) -1 
go  to  25 

27  itgl (i) -itgl (i) -2 
16  i  -  i  +1 

if (  i  .gt.nlbl)goto200 
if (  itgl (i)-l)25,28,29 

28  itgl (i) -itgl (i) +1 
go  to  16 

29  itgl (i) -itgl (i) -1 
go  to  16 

200  icheck=l 
go  to  236 
25  icheck-0 
go  to  36 

30  if (iopt) 32,341,32 

32  if (if ile2 . eq. 1 ) goto341 

read (nctape) nlbl,  lastrc,iil, j  jl, kkl, 111, itgl , mul , vin 
go  to  36 

341  read (nit ape) nlbl, last rc,  iil , j  jl, kkl , 111 , itgl , mul 
36  if (  icheck . eq. 1 ) gotol 3 
236  lrecnt=lrecnt+l 

if (nlbl . le . 0) got o7 00 

if (icon (1 ) . eq. 2 . and. if ile2 . eq. 1 ) goto237 
if (nlbl.gt.ninmax)goto810 
237  nlbtot-nlbtot+nlbl 
do  600ij-l,nlbl 
k2-i  j 

if (ifile2 .eq. 0) goto54 
if (iopt.eq. 0)goto54 
go  to  60 

54  if (nogg)  55, 55,  60 

55  if (itgl (ij) -1) 60,  56,  58 
56  if(ikp >600,57,600 

57  continue 
go  to  600 

58  if(ikp >600,59,600 

59  if  (if  ile2  .eq.  1 .  and.  abs  (prvint )  .gt.O.Dthen 
icl-icl+1 

dpval (icl) --prvint 
c  iql (icl) -iil (i j) +180* j jl  (i  j) 
c  jql (icl) -kkl (ij) +180*111  (ij) 
c  kql (icl) -0+180*mul (i j) 
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endif 
go  to  600 
60  i-iil(ij) 
j-jjl <ij) 

k-kkl  (i j) 
1-111  (ij) 
itag-itgl (i  j) 
nint-nint+1 


ikp-0 

if (iopt) 40,80,40 
40  if (ifile2 . eq. 0) goto66 

if (if rst .eq. 0) goto64 
if (icntl . It . nintl ) goto65 

64  read (nctape) nintl, ltestl, vin 
if rst-1 

icntl-0 

ninmax-nintl 

65  if (itag.eq. 0) goto651 
nint-nint-1 

go  to  600 

651  icntl-icntl+1 

k2-icntl 
nint-icntl 


66  do  50  n-l,nlist 


if  ( 

mlist (n) ■ 

-i) 

44, 

80, 

,44 

44 

if  ( 

mlist (n) ■ 

-j) 

46, 

80, 

,46 

46 

if  ( 

mlist (n) ■ 

-k) 

48, 

80, 

48 

48 

if  ( 

mlist (n) ■ 

-1) 

50, 

80, 

50 

50 

continue 

valint (nint) =vin (k2) 
prvint-vin (k2) 
nzrlbl=nzrlbl+l 
nzrint-nzrint+1 
if (if ile2 . eq. 1 ) got o2 002 
go  to  402 

80  nzrlbl=nzrlbl+l 

valint (nint) =0 . dO 
if ( jean) 120,120,180 

120  if  (  ntype ( j) -ntype (i) ) 140, 140, 130 
130  iii-i 


i  -  j 
j=iii 

140  if  (  ntype (1) -ntype (k) ) 160, 160, 150 
150  iii-k 

k  =  1 

l=iii 

160  if  (  ntype (k) -ntype (i) )  180, 165,  17C 

165  if  (  ntype (1) -ntype (j) ) 180,  180,  17C 
170  iii-i 

i  -  k 
k-iii 
iii-j 

j  '  1 
1-iii 

180  icnt-ncntr (i) 
jent-nentr ( j ) 
kent-nentr (k) 
lent-nentr (1) 
ityp-ntype (i) 
jtyp-ntype ( j) 
ktyp-ntype (k) 
ltyp-ntype (1) 
is-nf irst (i ) 
js-nfirst  ( j) 
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ks-nfirst (k) 
ls-nfirst (1) 
if«nlast (i) 
jf-nlast  ( j) 
kf-nlast (k) 
lf-nlast (1) 

if  (  ityp-4 >320,320,321 

320  if  (icnt- jcnt) 350, 351, 350 

351  if  (kcnt-lcnt) 350, 352, 350 

352  if  (icnt-kcnt) 350, 353, 350 

353  call  spones (eta, valint, ngmx, ninmax) 
go  to  250 

350  call  spirits  (eta,  valint,  s,  ngmx,  ninmax,  nsavmx) 
go  to  250 

321  if  (  ityp-10) 420, 420, 421 

421  if  (icnt- jcnt) 450, 451, 450 

451  if  (kcnt-lcnt) 450,452,450 

452  if  (icnt-kcnt) 450, 453, 450 

453  call  spdone (eta, valint , s, nr, ntmx, ngmx, ninmax, nsavmx) 
go  to  250 

450  call  spdfnt  (eta,  valint,  s,  nr,  ntmx,  ngmx,  ninmax,  nsavmx) 
go  to  250 

420  if  (icnt- jcnt) 360, 361, 360 

361  if  (kcnt-lcnt) 360, 362, 360 

362  if  (icnt-kcnt) 360, 363, 360 

363  call  spdone  (eta,  valint ,  s,  nr,  ntmx,  ngmx,  ninmax,  nsavmx) 
go  to  250 

360  call  spdint  (eta, valint, s, nr, ntmx, ngmx, ninmax, nsavmx) 

250  prvint-valint (nint ) 
nzrint=nzrint+l 

2002  continue 

if (ifile2 .ne. 1) goto402 

if (dabs (prvint) . le. scale) valint (nint) =0 .cO 
go  to  2009 

c  we  set  all  computed  integrals  belcw  the  threshold  to  zero, to  help 
c  testing  in  gvb(uhf) 

c  all  unique  integrals  must  be  kept, so  that  labels  tape  need  not 
c  be  reset. 

402  if (dabs (prvint) -scale) 404, 411, 411 
c  do  not  write  this  integral  on  tape. 

404  nint  -nint-1 

nzrint=nzrint-l 

ikp-1 

go  to  600 

411  ii2 (nint) -iil (i j) 
j  j  2 (nint) -j jl  (i j) 
kk2 (nint) -kkl  (i j) 

112 (nint) -111 (i j) 
itg2 (nint) -itgl (i j) 
mu2 (nint) -mul (i j ) 

2009  continue 

if  (  nint-ninmax) 600, 412, 412 
c  write  out  an  integral  record. 

412  irecnt-irecnt+1 

nintot-nintot+nint 
if (ltestl .ne.0) 1 zero-1 

if (if ile2 . ne . 1) write (not ape) nint,lzero,ii2, jj2, kk2, 112, itg2,mu2, 
xvalint 

if (ifile2 .eq. 1) write (not ape) nint, 1 zero, valint 
if (ltestl. ne.0)goto805 
nint  -0 

600  continue 

700  if  (  lastrc.eq. 0)goto30 
nintot-nintot+nint 
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if (ifile2 . ne . 1 ) write { not ape ) nint, last rc, ii2 , j  j2, kk2, 112, itg2,mu2, 
xvalint 

if (if ile2 .eq. 1) write (notape) nint,  last rc,  valint 
write (60, 996) nlbtot, nzrlbl, nintot, nzrint 
if (ifile2 . eq. 1 . and. (.not. (nzrlbl . eq. nintot . and. 

1  nintot . eq. nzrint) )) stop' last  three  quantities  not  equal- 

2  -  as  required  by  ifile2-l' 

805  return 

810  write (60, 989) lrecnt 
stop 

989  format (/5x, 25htoo  many  labels  in  record  ,i!0) 

996  format (9x,  i7, '  labels, ',  i8, '  unique' , 5x, i7, '  integrals  written,', 
2  i8,'  unique'//) 

1420  format ('  generf  -  generate  f-integral  tables' , 5x, ' maxtyp  -',i3, 

2  5x,'maxrng  *',i5//) 

141C  format ('  savrge  -  compute  pre-exponential  factors'//) 
end 

subroutine  generf  (maxtyp, maxrng) 
implicit  double  precision (a-h, o-z) 

common/ inc/x 3, x5, x7,  x9, xll ,xl3,xl5,xl7,x!9,x21,x23,x25 
common/ st ore/ st rO (280)  ,  strl (280) , str2  (280) , str3 (280) , str4  (280) , 
lstr5 (280) , str6 (280) ,str7 (280) , str8 (280) , str9 (280) , strlO (280) , 
2strll (280) , strl2 (280) 
maxrng-240 

if  (maxtyp-4) 762, 762, 761 

761  maxrng-280 

762  continue 
t-0 .d0 

do  779i*l, maxrng 
y=exp (-t) 
u=2 .  d0*t 

if  <maxtyp-4 ) 764, 764 , 765 

765  strl2 (i) =fmch (12, t, y) 
strll(i)=(u*strl2(i)+y)*x23 
strlO (i) = (u*strll (i) +y) *x21 
str9(i)-(u*strl0(i)+y)*xl9 
str8 (i)»(u*str9 (i)+y) *xl7 
go  to  766 

764  str8 (i) -fmch (8,  t,y) 

766  str7 (i) = (u*str8 (i) +y) *xl5 
str6(i)-(u*str7(i)+y)*xl3 
str5 (i) - (u*str6 (i) +y) *xll 
str4 (i) - (u*str5 (i) +y) *x9 
str3 (i) = (u*str4 (i) +y) *x7 
str2 (i) = (u*str3 (i) +y) *x5 
strl (i) « (u*str2 (i) +y) *x3 
strO (i) « (u*strl (i) +y) 

779  t-t+O.ldO 
return 
end 

subroutine  savrge  (ngaus,eta, s, ngmx, nsavmx) 
implicit  double  precision (a-h, o-z) 
dimension  eta(ngmx,5),  s(nsavmx),  ab ( 3 ) 
common/nmbrs/pi,piterm,pitern,  acrcy,  scale 
indx-  0 

do  750ii=l , ngaus 
a»  eta (ii,  4) 
do  750jj-l,ii 
indx«  indx+1 
b-  eta ( j j, 4) 
tl»  1 . 0d0/ (a+b) 
ab (1) -eta (ii, 1 ) -eta  ( j  j, 1 ) 
ab  (2) -eta (ii, 2) -eta  ( j j, 2 ) 
ab(3) -eta (ii, 3) -eta ( j j, 3) 
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dab-  ab(l)*ab(l)+ab<2) *ab(2)+ab(3) *ab(3) 

s (indx) -pitern* (tl**l . 5d0) *exp (-a*b*dab*t 1 ) *eta (ii,5)*eta(jj 

x,  5) 

750  continue 

return 
end 

subroutine  spones  (eta, valint, ngmx, ninmax) 
implicit  double  precision (a-h, o-z ) 
dimension  _eta (ngmx, 5) , valint (ninmax) 

common/specs/icnt, jcnt, kcnt, lent,  ityp, jtyp, ktyp, ltyp, is, js, ks, 
lls,if,jf,kf,lf,m, i, j,k,l 
common/nmbrs/pi, piterm, pitern, acrcy , scale 
fctrab-1 . dO 
f ctrcd-1 . dO 
do  245ii=is,if 
a=eta (ii,  4 ) 
if  (i-j) 680, 681, 680 

681  jf-ii 

f ctrab-2 . dO 
680  do  244 j j  =  js,  jf 
b=eta ( j j,  4) 
tl-a+b 

if (ii-jj) 431,432,431 
432  fctrab-1. dO 
431  do  243kk-ks,kf 
c-eta  (kk, 4 ) 
if  (k-l)6S3, 682,683 

682  lf-kk 

f ctrcd=2 . OdO 

683  do  24211-ls, If 
d=eta  (11,4) 

if  (kk-ll)436, 435,436 

435  f ctrcd-1 . dO 

436  rawint-O.dO 
t2-c-*-d 
t4-tl+t2 
tlt2-tl*t2 

w«34 . 9868365d0/dsqrt ( 1 4 ) 
if  (ityp-1 ) 405, 406, 405 

405  if  (ktyp-1) 860, 831, 860 
831  if  (ityp- jtyp) 242, 862, 242 
860  if  (jtyp-1) 870, 871,870 

871  if  (ltyp-1) 870, 872, 870 

872  if  (ityp-ktyp) 242, 873, 242 
870  if  (ityp- jtyp) 880, 881, 880 
881  if  (ktyp-ltyp) 242, 883, 242 

883  if  (ityp-ktyp) 884, 885, 884 
880  if  (ityp-ktyp) 242, 886, 242 
886  if  ( jtyp-ltyp) 242, 887, 242 

406  rawint=w/tlt2 
go  to  999 

862  tlt4-tlt2/t4 

tlt4«0.5d0/tl* (1. dO-tlt 4/ (3.d0*tl) ) 

rawint-w/tlt2*tlt4 

go  to  999 

873  tit 4-0 . 5d0 / (3 . d0*t4 ) 
rawint-w*tlt4/tlt2 
go  to  999 

885  tlt4-tlt£/t4 

rawint- (X . dO- (1 .dO/3 . dO) +3 . dO* (tlt4**2)/ (5.d0*tlt2) ) *w/ (4 .dO* (tlt2 
x) **2) 
go  to  999 

884  tlt4-tlt2^t4 

rawint- (1 .dO- (I.d0/3.d0)+(tlt4**2)/ (5.d0*tlt2) ) *w/ (4 . dO* (tit 2) * 
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x*2) 

go  to  999 
887  tlt4«tlt2/t4 

rawint-tlt4**2/  <5.d0*tlt2) *w/ (4 .d0*tlt2**2) 

999  rawint-rawint*eta  (ii,  5)  *eta  ( j  j,  5)  *eta  (kk,  5)  *eta  (11,  5)  *fctrab*f ctrc 
xd 

242  valint (m) -valint (m)  +rawint 

243  continue 

244  continue 

245  continue 
return 
end 

subroutine  spdone  (eta,  valint ,  s,  nr,  ntmx,  ngmx,  ninmax,  nsavmx) 
implicit  double  precision (a-h, o-z) 
dimension  f(13),c(13,3) ,mhi (3) , zz (13) 

dimension  eta (ngmx, 5) , s (nsavmx) , valint (ninmax) , nr (ntmx, 3) 
common/specs /icnt, jcnt, kcnt, lent, ityp, jtyp,  ktyp, ltyp, is, js, ks, 

11s, if , jf , kf , If ,m,  i, j, k, 1 
common/’nmbr3/pi,  piterm,pitern,  acrcy,  scale 

data  f (l)/l.dO/,f (2)/.33333333d0/,f (3)/.2d0/,f (4)/.14285714d0/,f (5 
x) /.lllllllldO/, f (€) /. 09090 9091d0/, f (7) , . 076923077d0/, f (8) /. 0666666 
x67d0/,f (9)/. 058823529d0/,f( 10)/. 05263157 9d0/,f (11) /. 04761 9047d0/,f 
x(12)/.043478261d0/,f(13)/.04d0/ 
fab**l  .d0 
f cd*l . dO 
do  353ii*is,if 
a=eta (ii, 4) 
if  (i-j) 680,681,680 

681  jf-ii 
fab«2 . dO 

680  do  352  j  j=>  js,  jf 
b=eta ( j j, 4) 
tl=a+b 

tab“0 . 25d0/tl 

index  -maxO  (ii,  j  j)  *  (maxO  (ii,  j  j)  -1)  /2+mir.O  (ii,  j  j) 
saboo-s (index) 
if (ii-j j)431,432,431 
432  fab-l.dO 
431  do  351kk-ks,kf 
cx»eta (kk, 4 ) 
if  (k-1) 683, 682, 683 

682  lf-kk 
fcd-2.d0 

683  do35511«ls,lf 

if  (kk-ll)436,435,436 

435  fcd-l.dO 

436  continue 
d»eta (11,4) 
t2»cx+d 
tcd*0 . 25d0/t2 
prtint«*0  .dO 
wx»l .dO 
do346n-l,3 
kt«n 
gab-tab 
ged-ted 

ni j-nr (ityp, kt) +nr ( jtyp, kt) +1 
nkl-nr (ktyp, kt) +nr (ltyp, kt) +1 
go  to  (200,201,202,203,204,205,206) ,nij 

200  go  to  (239, 499, 241, 499, 242, 499, 529), nkl 

201  go  to  (499, 243, 499, 244, 499, 530,  499), nkl 

202  go  to  (245, 499, 246, 499, 247, 499, 531), nkl 

203  go  to  (499,249,499,250,499,532,499) , nkl 

204  go  to  (251, 499, 252, 499, 254, 499, 533), nkl 
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205  go  to  <499, 534, 499, 535, 499, 536, 499), nkl 

206  go  to  (537, 499, 538, 499, 539, 499, 540), nkl 

c . (0)  (0) 

239  c(l,kt)-l.d0 
msum-1 
go  to  399 
c . (0)  (2) 

241  c(l,kt)»2.d0*gcd 
c(2,kt)— 2.d0*gcd*gcd 
msum-2 

go  to  399 
c . (0)  (4) 

242  gg-gcd*gcd 

c  (1, kt) -12 .d0*gg 
c  (2,kt)— 24.d0*gcd*gg 
c (3,kt)-12.d0*gg*gg 
ms urn- 3 
go  to  399 
c . (0)  (6) 

529  gcd2-gcd*gcd 
gcd4-gcd2*gcd2 

c (I,kt)-120.d0*gcd*gcd2 
c  (2,kt)— 360.d0*gcd4 
c  (3,kt)-360.d0*gcd*gcd4 
c (4, kt) *-120 . d0*gcd2*gcd4 
msum-4 
go  to  399 
c . (1)  (1) 

243  c (1, kt) *0 . dO 

c (2, kt) *2 . d0*gab*gcd 
msum-2 
go  to  399 
c . (1)  (3) 

244  gg»gcd*gcd 

c (1, kt) *0 .d0 
c (2, kt) *12 . d0*gg*gab 
c  (3, kt) — 12 . d0*gab*gcd*gg 
msum-3 
go  to  399 
c . (1)  (5) 

530  gcd2»gcd*gcd 
gcd4*gcd2*gcd2 
gabcd*gab*gcd 
c  (1,  kt)  *0 .  dO 

c (2, kt) *120 .d0*gabcd*gcd2 
c  (3, kt) *-240 .d0*gab*gcd4 
c (4, kt) -120 .d0*gabcd»gcd4 
msum-4 
go  to  399 
c . (2)  (0) 

245  c (1, kt) -2 . d0*gab 

c (2, kt) *-2.d0*gab*gab 
msum-2 
go  to  399 
c . (2)  (2) 

246  gg-gab*gcd 

c (1, kt) -4 .d0*gg 
c (2, kt) — 4 .d0#gg* (gab+gcd) 
c (3, kt) -12 .d0*gg*gg 
msum-3 
go  to  399 
c . (2)  (4) 

247  ggab-gab*gab 
ggcd-gcd*gcd 
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gg-ggab*ggcd 
c (1,  kt) -24 .dO*ggcd*gab 
c  ( 2 ,  kt )  —2 4 .  dO * ggcd*  (ggab+2 .  dO  * gab*gcd) 
c (3,kt)-24.d0* (6.d0*gcd*gg+ggcd*ggcd*gab) 
c  (4,kt)— 120.d0*gg*ggcd 
maum-4 
go  to  399 
c . (2)  (6) 

531  gcd2-gcd*gcd 
gcd4«gcd2*gcd2 
gabcd-gab*gcd 
gabcd4«gab*gcd4 

c (1, kt) -240 .d0*gabcd*gcd2 

c (2, kt) — 240 .d0*gab*gcd2* (3 . d0*gcd2+gabcd) 
c (3,kt)-720.d0*gabcd4* (3 ,dO*gab+gcd) 
c  (4,  kt)  —240  .d0*gabcd4*  (15 . d0*gabcd+gcd2 ) 
c (5,kt) -1680 .d0*gab*gab*gcd2*gcd4 
maum-S 
go  to  399 
c . (3)  (1) 

249  gg-gab*gab 

c (1,  kt) -0 .dO 
c (2,kt)-12.d0*gg*gcd 
c (3,  kt) — 12.d0*gab*gcd*gg 
msum»3 
go  to  399 
c . (3)  (3) 

250  ggab-gab*gab 
ggcd-gcd*gcd 
gg-ggab*ggcc'. 
c  (1,  kt)  -0  .  dO 

c (2, kt) -72 .d0*gg 
c (3, kt ) — 72 .d0*gg* (gab+gcd) 
c (4, kt) -120 .d0*gg*gab*gcd 
m3 urn- 4 
go  to  399 
c . (3)  (5) 

532  gab2=gab*gab 
gcd2-gcd*gcd 
gg=gab2  *gcd2  *gcd2 
c  (1,  kt)  -0  .dO 

c (2, kt) -720 . d0*gab2*gcd*gcd2 

c (3, kt) — 720 ,d0*gab2*gcd2* (2 . d0*gcd2+gab*gcd) 
c (4 , kt) -240 . d0*gg* (10 . d0*gab+3 . d0*gcd) 
c (5, kt ) --1680 . dO*gab*gcd*gg 
msum-5 
go  to  399 
c . (4)  (0) 

251  gg-gab*gab 

c (1, kt) "12 . d0*gg 
c (2, kt) »-24 .d0*gab*gg 
c (3, kt) -12 .d0*gg*gg 
msum-3 
go  to  399 
c . (4)  (2) 

252  ggab-gab*gab 
ggcd-gcd*gcd 
gg-ggab*ggcd 

c (1, kt) -24 .d0*ggab*gcd 

c (2, kt) — 24 .d0*ggab* (ggcd+2 .d0*gab*gcd) 

c (3, kt) -24 .dO* (6.d0*gab*gg+ggab*ggab*gcd) 

c(4,kt)--120. d0*gg*ggab 

maum-4 

go  to  399 
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c . (4)  (4) 

254  ggab-gab*gab 
ggcd-gcd*  gcd 
gg«ggab*ggcd 
c (l,kt)-144.d0*gg 
c (2, kt) — 288 .dO*gg* (gcd+gab) 
c (3, kt) -144 .dO*gg* (ggcd+12 . d0*gab*gcd+ggab) 
c (4, kt) — 1440.d0*gg* (gab*ggcd+gcd*ggab) 
c (5, kt) -1680 .dQ*gg*gg 
msum-5 
go  to  399 
c . (4)  (6) 

533  gab2-gab*gab 
gcd2-gcd*gcd 
gg=gab2*gcd2 

c ( 1 , kt ) -1 4  4  0 . dO  *gg* gcd 

c (2, kt) — 1440 .d0*gg* (3.d0*gcd2+2 ,dO*gab*gcd) 
c (3, kt) -1440 .d0*gg* (3.d0*gcd2* (gcd+6 . d0*gab) +gab2*gcd) 
c  (4,kt)--1440. d0*gg* {gcd2*gcd2+30 . d0*gab*gcd*gcd2+15 . d0*gg) 
c (5, kt) *10080 .d0*gg*gcd2* (2 . d0*gab*gcd2+5 . d0*gcd*gab2) 
c  (6,  kt)  —30240  .d0*gg*gg*gcd2 
m3  urn- 6 

go  to  399 
c . (5)  (1) 

534  gab-tcd 
gcd-tab 
go  to  530 

c . (5)  (3) 

535  gab-tcd 
gcd-tab 
go  to  532 

c . (5)  (5) 

536  gab2-gab*gab 
gcd2-gcd*gcd 
gabcd-gab*gcd 
gabcd2-gab2  *gcd2 
c (l,kt)-0.d0 

c (2, kt) -7200 .d0*gabcd2*gabcd 
c (3, kt) —14400. d0*gabcd2* (gab*gcd2+gcd*gab2) 
c (4, kt) -2400 .d0*gabcd2* (3 . d0*gabcd* (gab2+gcd2) +20 .d0*gabcd2) 
c (5, kt) — 33600 ,d0*gabcd2*gabcd2* (gab+gcd) 
c (6, kt) -30240 .d0*gabcd2*gabcd2*gabcd 
ms  urn- 6 
go  to  399 
c . (6)  (0) 

537  gab-tcd 
gcd-tab 
go  to  529 

c . (6)  (2) 

538  gab-tcd 
gcd-tab 
go  to  531 

c . (6)  (4) 

539  gab-tcd 
gcd-tab 
go  to  533 

c . (6)  (6) 

540  gab2-gab*gab 
gcd2-gcd*gcd 
gabcd-gab*gcd 
gabcd2-gab2  *gcd2 

c (1, kt) -14400 .d0*gabcd2*gabcd 

c (2,  kt) — ■ 43200 .d0*gabcd2* (gab*gcd2+gcd*gab2) 

c (3,  kt) -43200 .d0*gabcd2* (gabcd* (gab2+gcd2) +9.d0*gabcd2) 
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c  (4, kt)  — 14400 .d0*gabcd2*  (gab*gcd2*gcd2+45.d0*gabcd2*  (gab+gcd)  + 
x  gcd*gab2*gab2) 

c (5, kt) -302400.d0*gabcd2*gabcd2* (gab2+5.d0*gabcd+gcd2) 
c (6, kt) — 907200 . d0*gabcd2*gabcd2* (gab*gcd2+gcd*gab2) 
c (7, kt) “665280 .d0*gabcd2*gabcd2*gabcd2 
msum-7 
399  continue 

mhi (kt) -maum 
346  continue 
mx-mhi (1) 
my-tnhi  (2) 
mz-mhi (3) 
mxyzmx+my+mz-2 
z “gab+gcd 
z-1 .dO/z 
zz(l)-l.d0 
zz (2) »z 

if  (mxyz-2) 38C, 380, 382 
382  do  3811ife=3,mxyz 
nice-life-1 

381  zz (life) «z*zz (nice) 

380  continue 

rawint“0 . dO 

do390nx-l,mx 

do389ny“l,my 

do388nz“l,mz 

n-nx+ny+nz-2 

388  rawint-rawint+c  (nx,  1)  *c  (ny,  2)  *c  (nz,  3)  *zz  (n)  *f  (r.) 

389  continue 

390  continue 

index  -maxO (kk, 11) * (maxO (kk, 11) -1) /2+min0 (kk, 11) 

3cdoo*s (index) 
w=*0 . 25d0*z 

wx“piterm*dsqrt (w) *saboo*scdoo*f ab*fcd 
prtint-rawint 

355  valint (m) -valint (m) +wx*prtint 

351  continue 

352  continue 

353  continue 
499  continue 

return 

end 

subroutine  spints  (eta, valint, s, ngmx, ninmax, nsavmx) 
implicit  double  precision (a-h, o-z) 
dimension  eta (ngmx, 5) , s (nsavmx) , valint (ninmax) 
dimension  p(3),q(3),r(3),ab(4),cd(3) 

common/ store/ strO (280) ,  strl (280) ,  str2  (28  0 ) , str3  (28  0) , str4  (280) , 
lstr5 (280) , str6  (280)  ,str7  (280)  ,  str8  (280)  ,  str9  (2  3  0)  ,  strl 0  (280)  , 
2strll(280),strl2(280) 

common/specs/icnt,  jcnt,  kcnt,  lent,  ityp, jtyp, ktyp, ltyp, is, js, ks, 
11s, if , jf ,kf , If ,m,  i, j,  k,  1 
common /nmbr s /pi, pi term, pi te r n, acrcy, scale 
common/ inc/x3, x5,  x7,x9,xll,xl3,xl5,xl7,xl9,x21,x23,x25 
data  ab (1) /0 . 0d00/ 
fctrab*l .d0 
fctrcd“l .d0 
addi j“0 .d0 
addkl-O.dO 
smijoo“0.d0 
smioko-0 .d0 
smiool“0 .d0 
smo jko-0 .d0 
smookl“0.d0 
smo jol-0 .d0 
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smi  jko-0 .dO 
smi jol-0 .dO 
smiokl-O.dO 
smojkl-O.dO 

msum-ityp+ jtyp+ktyp+ltyp-4 
do  350ii-is,if 
a=eta  (ii, 4) 
if  (i-j) 680, 681, 680 

681  jf-ii 
fctrab-2 .d0 

680  do  351 j j- js, jf 
b-eta (j j, 4) 
tl-a+b 

ab  (2)  -eta  (ii,  1)  -eta  ( j  j,  1) 
ab  (3)  -eta  (ii,  2)  -eta  ( j  j,  2) 
ab  (4)  =eta  (ii,  3)  -eta  ( j  j,  3) 
abi=ab (ityp) 
abj-ab< jtyp) 

index  -maxO (ii, j j) * (maxO (ii, j j) -1) /2+minO  (ii, j j) 

saboo-s (index) 

if  (icnt- jcnt) 704, 708, 704 

704  continue 

p (1) - (a*eta (ii, 1) +b*eta ( j j, 1) ) /tl 
p (2) - (a*eta (ii, 2) +b*eta ( j j, 2) ) /tl 
p (3) - (a*eta (ii, 3) +b*eta  ( j j, 3) ) /tl 
go  to  709 

708  p (1) »eta  (ii, 1) 
p(2) -eta (ii, 2) 
p(3)=eta(ii,3) 

709  continue 

if  (ii-jj)431,432,431 
432  fctrab-l.dO 
431  do  352kk=ks,kf 
C=*eta  (kk,  4 ) 
if  (k-1) 683, 682, 683 

682  lf-kk 
fctrcd-2 . dO 

683  do  35311-ls, If 

if  (kk-11) 436, 435, 436 

435  fctrcd-l.dO 

436  continue 
d=eta (11,4) 
t2»c+d 

cd(l) =eta (kk, 1) -eta (11,1) 
cd(2) -eta (kk, 2) -eta (11,2) 
cd(3) -eta (kk, 3) -eta (11,3) 
cdk-cd(ktyp-l) 
cdl-cd(ltyp-l) 

index  -maxO (kk, 11 ) * (maxO (kk, 11) -1) /2+minO  (kk, 11) 

3cdoo— 3 (index) 

t4-tl+t2 

tlt4-tl/t4 

w-t2*tlt4 

wx-piterm*dsqrt (w) *saboo*scdoo*fctrab*fctrcd 
test-2 . d0*wx 

if (dabs (test) -acrcy) 540,750,750 
750  continue 
t2t4-t2/t4 

if  (kcnt-lcnt) 705, 706, 705 

705  continue 

q(l) - (c*eta (kk, 1) +d*eta  (11, 1) ) /t2 
q(2)-(c*eta(kk,2)+d*eta(ll,2) ) / t2 
q(3) - (c*eta (kk, 3)+d*eta(ll, 3) ) /t2 
go  to  707 
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706  q(l) -eta (kk,  1) 
q(2)-eta(kk,2) 
q(3) -eta (kk,  3) 

707  continue 
r(l)-p(l)-q(l) 

r(2)-p(2)-q<2) 
r  (3)-p(3)-q(3) 

pqsq-r (1) *r(l)+r(2)*r(2)+r(3) *r<3) 

ri-r (ityp-1) 

rj-r( jtyp-1) 

rk-r (ktyp-1) 

rl-r (ltyp-1) 

rawint-0 .d0 

if  (pqsq) 461, 461, 462 

461  f 4«x9 
f  3-x7 
f2-x5 
f  l-x3 
fO-l.dO 
go  to  463 

462  t-w*pqsq 

if  (t-23.9d0) 4620, 4621, 4621 

4620  continue 

x-10 .d0* (t+0 . 05d0) 

it-  x 

ti-it 

it-it+1 

delt-t-0 . Id0*ti 
delt2-0 . 5d0*delt 
delt3— delt*x3 

c  correction  here  8/70-wyh-thd  got  info  from  basch 

c  delt4-0 . 25d0*delt 

delt4— 0 . 25d0*delt 
tf O-strO (it) 
tfl-strl (it) 
tf2-str2 (it) 
tf3-  str3(it) 
tf4-str4 (it) 
if  (m3um) 1462, 1462, 1463 

1463  continue 

tf 5»str5 (it) 
tf6«str6 (it) 
tf7-str7 (it) 
tf 8»str8 (it) 

f 4-tf 4+delt* (-tf 5+delt2* (tf6+delt3* (tf 7+delt4*tf 8) ) ) 
f 3-tf 3+delt* (-tf 4+delt2* (tf5+delt3* (tf 6+delt4*tf 7) ) ) 
f2-tf2+delt* (-tf 3+delt2* (tf 4+delt3* (tf 5+delt4*tf 6) ) ) 
fl-tfl+delt* (-tf 2+delt2* <tf3+delt3* (tf 4+delt4*tf 5) ) ) 

1462  continue 

f 0-tf 0+delt* (-tf l+delt2  * (tf2+delt3* (tf3+delt4*tf4) ) ) 
go  to  463 

4621  continue 
xd-1 .dO/t 

f0«. 88622692d0*dsqrt (xd) 
if  (msum) 463, 463, 1467 

1467  continue 

fl-0 . 5d0*xd*f 0 
f2-l . 5d0*xd*f 1 
f 3-2 . 5d0*xd*f2 
f4-3.5d0*xd*f3 

463  continue 

goto  (205,202,203,204) , ityp 
201  write (60, 200) ityp, jtyp, ktyp, ltyp 
stop 
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202  go  to  (206,207,201,201) , jtyp 

203  go  to  (210,211,212,201) , jtyp 

204  go  to  (214,215,216,217) , jtyp 

206  go  to  (218,422,201,201) ,  ktyp 

207  go  to  (222,223,201,201) , ktyp 

210  go  to  (218,227,420,201) , ktyp 

211  go  to  (230,231,232,201) , ktyp 

212  go  to  (222,235,236,201) , ktyp 

214  go  to  (218,227,472,419) , ktyp 

215  go  to  (230,231,244,769) , ktyp 

216  go  to  (230,247,248,249) , ktyp 

217  go  to  (222,251,252,253) , ktyp 

419  go  to  (219,470,470,421) , ltyp 

420  go  to  (219,470,421,201) , ltyp 
422  go  to  (219,421,201,201) , ltyp 
472  go  to  (286,387,287,201) , ltyp 
223  go  to  (254,180,201,201) , ltyp 
227  go  to  (286,287,201,201) , ltyp 

231  go  to  (260,261,201,201) , ltyp 

232  go  to  (262,263, 987,201) , ltyp 

235  go  to  (264,265,201,201) , ltyp 

236  go  to  (254,283,180,201) , ltyp 
244  go  to  (354,270,271,201) , ltyp 
769  go  to  (262,263,277,987) , ltyp 

247  go  to  (354,271,201,201) , ltyp 

248  go  to  (260,275,261,201) , ltyp 

249  go  to  (262,277,263,987) , ltyp 

251  go  to  (264,265,201,201) , ltyp 

252  go  to  (264,281,265,201) , ltyp 

253  go  to  (254,283,283,180) , ltyp 

C  SS3S 

205  rawint~f0 
go  to  999 

c  X333, ysss, zsss 

218  if  (abi) 710,711,710 
711  rawint*-t2t4*ri*f 1 

go  to  999 

710  rawint»-b*abi*f 0/tl-t2t4*ri*f 1 
go  to  999 

c  xsxs,ysys, zszs 

219  prtint=0 . 5d0*f l/t4 
319  siooo--t2t4*ri 

sooko*tlt4*rk 
if  (abi) 740,741, 740 

741  if  (cdk) 746,742,746 
746  sko--d*cdk/t2 

rawint*siooo* (sko*fl+sooko*f2) +prtint 
go  to  999 

742  rawint»sooko*siooo*f 2+prtint 
go  to  999 

740  sio— b*abi/tl 

if  (cdk) 743,744, 743 

744  rawint-sooko* (sio*il+siooo*f2) +prtint 
go  to  999 

743  sko--d*cdk/t2 

rawint«sko* (sio*f 0+siooo*f 1 ) +sooko* (sio*f l+siooo*f2) +prtint 
go  to  999 

c  xx  s  3 , yy 33, Z  Z  3  s 

222  siooo"-t2t4*ri 

if  (abi) 716,717, 716 

717  rawint-(f0-t2t4*fl) *0. 5d0/tl+f2*3iooo**2 
go  to  999 
716  continue 

rawint- (f 1* (siooo*abi* (a-b) -0 . 5d0*t2t4) +f 0*  (0 . 5d0-a*abi*b*ab j/tl) ) 

' 
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x/tl  +  f2*siooo**2 

go  to  999 

c  ysxs, zsx3, zsys 

286  prtint-O.dO 
go  to  319 

c  yxss, zxas, zyss 

230  siooo— t2t4*ri 
so joo— t2t4*r j 
if  (icnt-jcnt) 718, 719, 718 

719  rawint~f2*siooo*so joo 
go  to  999 

718  continue 

rawint- (fl* (siooo*a*ab j-so joo*b*abi) -a*b*abi*ab j*f 0/tl) /tl+f2* 
x  siooo*sojoo 

go  to  999 

c  xsxx, ysyy, zszz 

421  addkl»0.5d0/t2 

smioko-O . 5d0*f l/t4 
smiool*smioko 
smookl— tlt4*f  l*addkl 
smiokl*l . 5d0*tlt4*ri*f2/t4 
387  sio— b*abi/tl 
siooo— t2t4*ri 
sooko-tlt4*rk 
soool“tlt4*rl 

sookl«sooko*soool*f2+smookl 
sioko-siooo*sooko*f2+smioko 
siool**siooo*soool 
siokl»siool*3ooko*f 3+smiokl 
siool“siool*f2+smiool 
if  (kcnt-lcnt) 720, 721 , 720 
721  if  (addkl) 760,761, 760 
761  rawint«sio*sookl+siokl 
go  to  999 
760  continue 
skl«addkl 

rawint~skl* (sio*f0+siooo*f 1) +sio*sookl+siokl 
go  to  999 

720  continue 
sko— d*cdk/t2 
sol«c*cdl/t2 
skl-sko*sol+addkl 

rawint=skl* (sio*f0+siooo*fl)+sko* (sio*soool*f 1+siool) +  sol* (sio*soo 
x  ko*f  1  +  sioko) +sio*sook.l+siokl 

go  to  999 

c  ysxx, zsxx, zsyy 

287  addkl«0.5d0/t2 

smiokl»0 . 5d0*tlt4*ri*f2/t4 
smookl— tlt4*f 1* addkl 
go  to  387 

c  ysyx, zszx, zszy 

470  smioko**0 . 5d0*f  l/t4 

smiokl-0 . 5d0*tlt4*rl*f2/t4 
go  to  387 

c  xxxs, yyys, zzzs 
254  addi j*0 . 5d0/tl 

smo jko-0. 5d0*f l/t4 
smioko-smo jko 
smi  joo— t2t4*f  l*addi  j 
smi  jko— t2t4*l . 5d0*ri*f2/t4 
354  continue 

sko— d*cdk/t2 
siooo— t2t4*ri 
so  joo— t2t4*r  j 
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sooko-tlt4*rk 

si joo-siooo*so joo*f2+smi joo 
3ioko-siooo*sooko*f2+smioko 
so jko-so joo*sooko 
si jko-so jko*siooo*f 3+smi jko 
so jko-so jko* f2+smo  jko 
if  (icnt- jcnt) 722,723, 722 
723  if  (addi j) 765,766,765 
766  rawint-sko*si joo+si jko 
go  to  999 
765  continue 
si j-addi j 

rawint-si j*  <sko*fO+sooko*fl) +sko*si joo+si jko 
go  to  999 
722  continue 

sio— b*abi/tl 
so j-a*ab j/tl 
si j-sio*so j+addi j 

rawint-si j* (sko*f 0+sooko*fl) +  sio* (sko*so joo*f 1+so jko) +so j* (sko*si 
x  ooo*f 1+sioko) +sko*si joo+si jko 

go  to  999 

c  yxxs, zxxs, zyys 
260  smo jko-0 . 5d0*fl/t4 

smi  jko— t2t4*0 . 5d0*ri*f2/t4 
go  to  354 

c  yxys, zxzsr zyzs 
262  smioko-0.5d0*fl/t4 

smi  jko— t2t4*0 . 5d0*r j*f2/t4 
go  to  354 

c  yyxs,  zzxs, zzys 
264  addi j-0 . 5d0/tl 

smi  joo— t2t4*fl*addi  j 

smi  jko— t2t4*0 . 5d0*rk*f2/t4 

go  to  354 

c  xxxx,yyyy, zzzz 
180  addi j-0. 5d0/tl 
addkl-0.5d0/t2 
smojko-0 . 5d0*fl/t4 
smioko-3mo jko 
smo jol-smo jko 
smiool-3mo jko 
smi  joo— t2t4*f  l*addi  j 
smookl— tlt4*f  l*addkl 
prtint-1 . 5d0*f2*ri/t4 
smi  jko— t2t4*prtint 
smi  jol-smi  jko 
smo jkl»tlt4*prtint 
smiokl-smo jkl 

smi  jkl— (3 . d0*tlt4*t2t4  *ri*r j*f 3-0 . 75d0*f 2/t4 ) /t4 
355  continue 

if  (pqsq) 777, 778, 777 
778  sio— b*abi/tl 
soj-  a*abj/tl 
sij-  sio*so j+addi j 
sko— d*cdk/t2 
sol-  c*cdl/t2 
skl-sko*sol+addkl 

rawint-si j* (skl*f 0+smookl) +sio* (sko*smo jol+sol*smo jko+smo jkl) + 
xso j* (sko*smiool+sol*smioko+smiokl) +skl*smi joo+sko*smi jol+ 
xsol*smi jko+smi  jkl 
go  to  999 
777  continue 

siooo— t2t4*ri 
sojoo— t2t4*r  j 


lopas. sub 


Fri  Apr  5  11:22:53  1991 


50 


sooko-tlt4*rk 
soool-tlt4*rl 
si joo-siooo*so joo 
sookl-soool*sooko 
si jkl-si joo*sookl*f4+smi jkl 
si jko-si joo*sooko* f 3+smi jko 
si jol-si joo*soool*f3+smi jol 
so jkl-so joo*sookl*f3+smo jkl 
siokl-siooo*sookl*f3+smiokl 
si joo-si joo*f2+smi  joo 
sookl-sookl*f2+smookl 
sioko-siooo*sooko*f2+smioko 
siool-siooo*soool*f2+smiool 
so jko-so joo*sooko*f2+smo jko 
so jol-so joo*soool*f2+smo jol 
if  (icnt- jcnt) 730, 731, 730 

731  if  (kcnt-lcnt) 732, 733, 732 

730  sio— b*abi/tl 

soj-  a*abj/tl 

si j-sio*so j+addi j 

if  (kcnt-lcnt) 734, 735, 734 

732  continue 
si j-addi j 
sko— d*cdk/t2 
sol-  c*cdl/t2 
skl-sko*  sol+addkl 
if  (sij) 770, 771, 770 

771  rawint-skl*si joo+sko* si jol+sol* si jko+si jkl 
go  to  999 

770  continue 

rawint-si j* (skl*f 0+sko*soool*f l+sol*sooko*f 1+sookl) +skl*si joo+ 
xsko*si jol+sol*si jko+si jkl 
go  to  999 

735  if  (addkl) 772,773,772 

773  rawint-si j* sookl+sio* so jkl+so j*siokl+si jkl 
go  to  999 

772  continue 
skl-addkl 

rawint-si j* (skl*f 0+sookl) +sio* (skl*so joo*fl+so jkl) +soj* (skl*siooo* 
xfl+siokl) +skl*si joo+si jkl 
go  to  999 

733  sij-addij 
skl-addkl 

rawint-si j* (skl*f0+sookl) +skl*si joo+si jkl 
go  to  999 

734  continue 
sko— d*cdk/t2 
sol-  c*cdl/t2 
skl-sko*sol+addkl 

rawint-si j* (skl*f0+sko*soool*fl+sol*sooko*f 1+sookl) +sio* (skl*so joo 
x  *fl+sko*so jol+sol*so jko+so jkl) +so j* (skl*siooo*f l+sko*sioo 

x  l+sol*sioko+siokl) +skl*si joo+sko*si jol+sol*si jko+si jkl 

go  to  999 

c  yxxx, zxxx, zyyy 

261  addkl-0 . 5d0/t2 

smo jko-0 . 5d0*f l/t4 
smookl— 1 1 1 4  *  f  1  *  addkl 
smo jol-smo jko 
prtint-0 . 5d0*f 2*ri/t4 
smiokl-tlt4*prtint 
smi  jko— t2t4*prtint 
smi jol-smi jko 
prtint-1 . 5d0*tlt4*rl/t4 
smo jkl-prtint*f2 
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smi  jkl— prtint* f  3‘ri*t2t4 
go  to  355 

c  yxyy, zxzz, zyzz 
987  addkl-0.5d0/t2 

smioko-0 . 5d0*f l/t4 

amookl— tlt4*f  l*addkl 

smiool-smioko 

prtint-0. 5d0‘f2‘r j/t4 

ami  jko— t2t 4 ‘prtint 

smi  jol-ami jko 

smo jkl-tlt4 ‘prtint 

prtint-1 . 5d0*tlt4*ri/t4 

smiokl«prtint*f2 

ami  jkl— prtint*f  3*r  j‘t2t4 

go  to  355 

c  yyyx, zzzx, zzzy 
283  addi j-0.5d0/tl 

amo jko-0 . 5d0*f l/t4 

amioko-smo jko 

smi  joo— t2t4*fl ‘addi  j 

prtint-0 . 5d0*f2*rl/t4 

smi  jol— t2t  4 ‘prtint 

smo jkl-tlt 4 ‘prtint 

smiokl-smo jkl 

prtint-1 . 5d0*t2t4*ri/t4 

smi  jko— prtint*f2 

ami  jkl— prtint  *f3*rl‘tlt4 

go  to  355 

c  yyxx, zzxx, zzyy 
265  addij»0.5d0/tl 
addkl-0 . 5d0 /t2 
3mi  joo— t2t4*fl*addi  j 
amookl— tlt4*fl*addkl 
prtint-0 . 5d0*f 2/t4 
3mi  jko— t2t4*prtint*  rk 
ami  jol-ami jko 
smo jkl-tlt 4 ‘prtint *rj 
smiokl-smo jkl 

smi jkl— 0. 5d0‘ (tlt4*t2t4*f3*  <ri*rj+rk*rl) -prtint) /t4 
go  to  355 

c  yxyx, zxzx, zyzy 

263  smioko-0 . 5d0*fl/t4 
smo  jol-smioko 
prtint-0 . 5d0*f2/t4 
smi jko— t2t  4 ‘prtint  *r j 
ami  jol— t2t4‘prtint*ri 
amo jkl«tlt4*prtint*rk 
3miokl«tlt4 ‘prtint ‘rl 

ami jkl— 0. 5d0* (tlt4*t2t4*f3* (ri*rk+r j‘rl) -prtint) /t4 
go  to  355 
c  zzyx 

281  addi j-0 . 5d0/tl 

ami  joo— t2t4*f  l*addi  j 
prtint-0 . 5d0*f2/t4*t2t4 
smi  jko— prtint  *rk 
ami  jol— prtint*  rl 

smi jkl— 0 . 5d0‘tlt4*t2t4*f 3*rk*rl/t4 
go  to  355 
c  zxyx 

270  amojol-0.5d0*fl/t4 
prtint-0 . 5d0*f 2/t4 
smi  jol— t2t 4 ‘prtint  *ri 
smo jkl-tlt4 ‘prtint *rk 
smi  jkl— 0. 5d0*tlt4*t2t4*f  3*ri*rk/t4 
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go  to  355 
c  zxyy,  zyxx 

271  addkl-0.5d0/t2 

smookl— tlt4*fl*addkl 
prtint-0.5d0*f2/t4*tlt4 
smo jkl-prtint*r j 
smiokl«prtint*ri 

smijkl— 0.5d0*tlt4*t2t4*f3*ri*rj/t4 
go  to  355 
c  zyyx 

275  smo jko-0 . 5d0*f l/t4 
prtint-0 . 5d0*f 2/t4 
smi  jko— t2t4*ri*prtint 
smo jkl-tlt4*rl*prtint 
smi  jkl— 0 . 5d0*tlt4*t2t4*f3*ri*rl/t4 
go  to  355 
c  zxzy,  zyzx 

277  smioko-0.5d0*fl/t4 
prtint-0 . 5d0*f 2/t4 
smi jko— t2t4*r j*prtint 
smiokl-tlt4*prtint*rl 
smi jkl—0 . 5d0*tlt4*t2t4  *f 3*  r j*  ri/t4 
go  to  355 
999  continue 

rawint“wx*rawint 
valint (m) «valint (m) +rawint 
540  continue 
353  continue 
352  continue 
351  continue 
350  continue 
return 

200  format  (  6h0error, 4i4 ) 
end 

subroutine  spdint  (eta,  valint,  s,  nr, ntmx, ngmx, ninmax, nsavmx) 
implicit  double  precision (a-h, c-z) 

dimension  eta (ngmx, 5) ,  valint (ninmax) , s (nsavmx) , nr (ntmx, 3) 
dimension  p(3),q(3),r(3),pa(3),pb(3),qc(3),qd(3),f(13),c(13,3), 
lmhi (3),zz(13),e(7,3), ndex (3) 

common/specs/icnt, jcnt,  kcnt, lent, ityp, jtyp, ktyp, ltyp, is, js, ks, 
lls,if,jf,kf,lf,m, i, j,  k,  1 
common/nmbrs/pi, pi term, pi tern, acrcy, scale 
common /gamma /f 0, fl,f2,f3,f4,f5,f6,f7,f8,f9,fl0,fll,fl2 
common / inc /x3, x5, x7, x9,  xl I,xl3,xl5,xl7,xl9,x21,x23,x25 
common/ store /strO (280),strl(280),str2(280),str3(280),str4(280), 
$  str5 (280) , str6  (280) ,  str7  (2  80)  ,  str8  (280) , str9  (280) , strlO (280)  , 
2strll (280) ,strl2 (280) 
equivalence (f (1)  ,  f 0) 
fab-l.dO 
fcd-l.dO 
abxyz»icnt- jcnt 
cdxyz«kcnt-lcnt 
abxyz-dabs (abxyz) 
cdxyz-dabs (cdxyz) 
do  353ii-is,if 
a-eta (ii, 4) 
if  (i- j) 680, 681, 680 
681  jf-ii 
fab-2.e0 

680  do  352jj«*js,jf 
b-eta  ( j j, 4) 
tl-l.d0/ (a+b) 
gab-0. 25d0*tl 

index  -maxO (ii, j j) * (maxO (ii,  j j) -1) /2+min0 (ii, j j) 
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saboo-s (index) 
if  (abxyz) 704, 708, 704 

704  continue 

p (1) - (a*eta (ii, 1) +b*eta ( j j, 1 ) ) *tl 
p(2)-(a*eta(ii,2)+b*eta( jj,2) ) *tl 
p (3) - (a*eta (ii, 3) +b*eta ( j j, 3) ) *tl 
go  to  709 

708  p (1) -eta (ii, 1) 
p(2)«eta(ii,2) 
p (3) -eta (ii, 3) 

709  continue 

pa (l)-p(l) -eta (ii, 1) 
pa (2) -p (2) -eta (ii, 2) 
pa (3) «p(3) -eta (ii, 3) 
pb ( 1 ) -p ( 1 ) -eta ( j  j , 1 ) 
pb(2) «p(2) -eta ( j j, 2) 
pb(3)»p(3)  -eta  ( j  j,  3) 
do  295kt»l,3 
ni-nr  (ityp, kt) 
nj-nr( jtyp,kt) 
pakt-pa (kt) 
pbkt-pb(kt) 
if  (ni-l)100,101,102 

100  if  (nj-l)103,104,105 

101  if  (nj-l)106,107,108 

102  if  (nj-l)109, 110,111 

c . 00 

103  index-1 
hlO-l.dO 
go  to  199 

c . 10 

106  hlO-pakt 
hll-gab 
index-2 
go  to  199 

c . 11 

107  index-7 

hl2«gab*gab 
if (abxyz) 150, 151, 150 
151  hlO-2 . d0*gab 
hll-O.dO 
gotol99 

150  hl0-pakt*pbkt+2 ,dQ*gab 
hll-gab* (pakt+pbkt) 
go  to  199 

c . 20 

109  index-5 

hl2-gab*gab 
if (abxyz) 152, 153, 152 
153  hlO-2 . d0*gab 
hll-O.dO 
gotol99 

152  hl0-pakt*pakt+2 .d0*gab 
hll-2 . d0*gab*pakt 
go  to  199 
c . 21 

110  gg-gab*gab 
index-14 
hl3-gab*gg 

if  (abxyz) 154,156,154 

156  hll-6.d0*gg 
hlO-O.dO 
hl2-0.d0 
gotol99 
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154  hl0-pakt*pakt*pbkt+2.d0*gab* (2.d0*pakt+pbkt) 
hll-gab*pakt* (2 . d0*pbkt+pakt ) +6 . dO  *gg 
hl2-gg* (2.d0*pakt+pbkt) 
go  to  199 

c . 22 

111  gg«gab*gab 
index-22 
hl4-gg*gg 

if  (abxyz) 157, 159, 157 

159  hl2-12.d0*gab*gg 
hl0-12.d0*gg 
hll-O.dO 
hl3-0.d0 
gotol99 

157  ab-pakt*pbkt 

apb- (pakt+pbkt ) * (pakt+pbkt ) +2 .  dO  *ab 
hl0-ab*ab+2 .d0*gab*apb+12 .dO*gg 
hll- (pakt+pbkt) * (2 . d0*gab*ab+12 . d0*gg) 
hl2-gg* (apb+12 . dO*gab) 
hl3-2.d0*gg*gab* (pakt+pbkt) 
go  to  199 

c . 01 

104  hlO-pbkt 
hll -gab 
index-2 
go  to  199 
c . 02 

105  index-5 

hl2-gab*gab 
if  (abxyz) 160, 153, 160 

160  hl0«pbkt*pbkt+2 . dO *gab 
hll«pbkt*2 . d0*gab 

go  to  199 

c . 12 

108  gg«gab*gab 
index- 14 
hl3»gab*gg 

if  (abxyz) 162, 156, 162 

162  h!0«pbkt*pbkt*pakt+2.d0*gab* (2 .d0*pbkt+pakt) 
hll»gab*pbkt* (2 .d0*pakt+pbkt) +6 . d0*gg 
hl2-gg* (2 .d0*pbkt+pakt) 

199  continue 

e(l,kt)-hl0 
e  (2, kt) -hll 
e (3, kt) -hl2 
e (4, kt) -hl3 
e (5, kt) -hl4 
ndex (kt) -index 
295  continue 

if(ii-jj)431,432,431 
432  fab-l.dO 
431  do  351kk-ks,kf 
cx-eta (kk, 4) 
if  ( k— 1 ) 683, 682, 683 
682  lf-kk 

fcd-2.d0 

683  do35511-l3.  If 

if  (kk-11) 436,435,436 

435  fcd-l.dO 

436  continue 
d-eta (11, 4) 
t2-l .e0/ (cx+d) 
gcd-0 . 25e0*t2 
z-  gab+gcd 
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z-1 .eO/z 

index  -maxO (kk, 11) * (maxO (kk, 11) -1) /2+minO (kk, 11) 
scdoo-s (index) 
w-0 .25e0*z 

wx-piterm*dsqrt  (w)  *saboo*scdoo*fab*f cd 
test-2 .eO*wx 
prtint-0 .eO 

if  (dabs (test) -acrcy) 540, 750, 750 

750  if  (cdxyz) 705, 706, 705 

705  continue 

q(l) - (cx*eta (kk, 1) +d*eta (11,1) ) *t2 
q (2) - (cx*eta (kk, 2) +d*eta (11,2) ) *t2 
q(3) - (cx*eta (kk, 3) +d*eta (11, 3) ) *t2 
go  to  707 

706  q(l)-eta(kk,l) 
q (2) -eta (kk, 2) 
q(3) -eta (kk, 3) 

707  r ( 1 ) -p ( 1 ) -q ( 1 ) 
r (2) «p (2) -q(2) 
r  (3)  -p  (3)  -q(3) 

pqsq-r (l)*r(l)+r(2)*r(2)+r(3)*r(3) 

qc (1) -q(l) -eta (kk, 1) 

qc (2) «q(2) -eta (kk, 2) 

qc (3) =q<3) -eta (kk, 3) 

qd (1 ) -q (1 ) -eta (11,1) 

qd(2) «q(2) -eta (11,2) 

qd(3) «q(3) -eta (11,3) 

rawint-O.dO 

do  346kt-l,3 

ni-nr (ityp, kt) 

nj-nr ( jtyp,kt) 

nk-nr (ktyp, kt) 

nl»nr (ltyp, kt ) 

msum-ni+n j+nk+nl+1 

if  (msum-1 ) 2, 2, 610 

610  continue 
qckt-qc (kt) 
qdkt-qd(kt) 
rkt=-r (kt) 
hlO-e (1, kt) 
hll-e (2, kt) 
hl2-e (3, kt) 
hl3-e (4 , kt) 
hl4-e (5, kt) 
index-ndex (kt) 
if (nk-1) 200,201,202 

200  if(nl -1)203, 204, 205 

201  if  (nl-l)206,207,208 

202  if(nl -1)209, 210, 211 

c . 00 

203  index-index+1 
hmO-l.dO 
goto299 

c . 10 

206  hmO-qckt 
hml— gcd 
index-index+2 
goto299 
c . 11 

207  index-index+7 
hm2-gcd*gcd 
if (cdxyz) 250,251,250 
251  hm0-2 .d0*gcd 

hml-O.dO 

I  "S3 
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goto299 

250  hm0-qckt*qdkt+2 .d0*gcd 
hml— gcd*  (qckt+qdkt) 
goto299 
c . 20 

209  index-index+5 
hm2-gcd*gcd 
if (cdxyz) 252, 253,252 
253  hm0«2.d0*gcd 
hml-0 .dO 
goto299 

252  hmO=*qckt*qckt+2.dO*gcd 
hml— 2 .  dO*gcd*qckt 
goto299 
c . 21 

210  gg»gcd*gcd 
index«index+14 
hm3— gcd*gg 

if (cdxyz) 254, 256,254 

256  hml— 6.d0*gg 
hmO-O.dO 
hm2-0 . dO 
goto299 

254  hm0«qckt*qckt*qdkt+2.d0*gcd* (2 . dO*qckt+qdkt) 
hml—  (gcd*qckt*  (2 .  dO*qdkt+qckt )  +6 .d0*gg) 
hm2«gg* (2.d0*qckt+qdkt) 
goto299 
c . 22 

211  gg«gcd*gcd 
index«index+22 
hm4»gg*gg 

if (cdxyz) 257, 259, 257 

259  hm2«12.d0*gcd*gg 
hm0=12 ,dO*gg 
hral-0 . dO 

hm3*0 .  dO 
goto299 

257  cd*qckt*qdkt 

cpd* (qckt+qdkt) * (qckt+qdkt) +2 . d0*cd 
hm0=cd*cd+2.d0*gcd*cpd+12 . d0*gg 
hml  — (qckt+qdkt) * (2 . d0*gcd*cd+l2 . d0*gg) 
hm2-gg* (cpd+12 . d0*gcd) 
hm3— 2.d0*gg*gcd*  (qckt+qdkt) 
goto299 
c . 01 

204  hm0**qdkt 
hml— gcd 
index*index+2 
goto299 
c . 02 

205  index-index+5 
hm2-gcd*gcd 
if  (cdxyz) 260, 253,  260 

260  hm0«qdkt*qdkt+2.d0*gcd 
hml— 2 .  d0*gcd*qdkt 
goto299 

c . 12 

208  gg«gcd*gcd 

index»index+14 
hm3— gcd*gg 
if  (cdxyz) 262, 256, 262 

262  hm0-qdkt*qdkt*qckt+2.d0*gcd* (2 .d0*qdkt+qckt) 
hml— (gcd*qdkt*  (2  .d0*qckt+qdkt)  +6.d0*gg) 
hm2-gg* (2.d0*qdkt+qckt) 
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299  continue 

goto (1,2, 3, 4, 1»6,7, 6, 7, 10, 1,10, 1,10, 15, 16, 1,1, 19, 1,19, 1,23, 24, 1,1 
127,28,27,1,1,1,1,1,1,36,1,1,1,1,1,1,1,44), index 

1  write  <60,  298)  index,  i,  j,  k,  1,  ii,  j  j,  kk,  11,  ni,  n  j,  nk,  nl,  kt 

298  format (i5, 13i5) 

stop 

c . 0000 

2  c(l,kt)-l.d0 
go  to  399 

c . 1000  0100  0010  0001 

3  if (ni+n j) 1, 310,311 

311  c (1, kt) -hlO 
c(2,kt)-rkt*hll 
go  to  399 

310  c(l,kt)-hm0 

c (2,  kt) -rkt*hml 
go  to  399 

cc. . . .1010  1001  0110  0101 

4  hlml-hll*hm0+hl0*hml 
hlm2-hll*hml 

312  c (1, kt) -hl0*hm0 

c (2, kt) «rkt*hlml-2 .d0*hlm2 
c (3, kt) -rkt*rkt*hlm2 
go  to  399 

c . 2000  0200  0020  0002  1100  0011 

6  if (ni+nj)l,  313,309 

313  hlml-hml 
hlm2-hm2 
goto312 

309  hlml-hll 
hlm2-h!2 
goto3l2 

c . 2010  2001  0210  0201  1020  1002  0120  0102  1110  1101  1011  0111 

7  if (ni+n j-nk-nl) 314 , 1, 315 

314  hlm2-hll*hml+hl0*hm2 
hlm3-hll*hm2 
goto3080 

315  hlm2-hll*hml+hl2*hm0 
hlm3«hl2*hml 

3080  hlml-hll *hm0+hl0*hml 

308  rkt2-rkt*rkt 
rkt3-rkt*rkt2 
c (1, kt) -hl0*hm0 
c (2, kt) -rkt*hlml-2 . d0*hlm2 
c (3, kt) -rkt2*hlm2-6 .d0*hlm3*rkt 
c (4, kt) -rkt3*hlm3 
go  to  399 

c . 2020  2002  0220  0202  2011  0211  1120  1102  1111 

10  hlml-hl0*hml+hll*hm0 

hlm2-hl0*hm2+hll*hml+hl2*hm0 
hlm3-hl2*hml+hll*hm2 
hlm4-hl2*hm2 
307  if  (rkt) 372,371,372 
372  if  (abxyz+cdxyz) 376, 376,  377 

376  rkt2-rkt*rkt 
rkt4-rkt2*rkt2 
c (1,  kt) -hl0*hm0 

c  (2,  kt)  — 2 . d0*hlm2 
c (3, kt) -rkt2*hlm2+12 . d0*hlm4 
c  (4, kt) — 12 .d0*rkt2*hlm4 
c (5, kt) -rkt4*hlm4 
goto399 

377  continue 
rkt2-rkt*rkt 
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rkt3»rkt*rkt2 

rkt4-rkt*rkt3 

c(l,kt)«hlO*hmO 

c (2, kt> «rkt*hlml-2 .d0*hlm2 

c { 3 , kt ) -rkt2  *hlm2 -6 . dO  *  rkt  * hlm3+l 2 . dO  *hlm4 

c (4, kt) -rkt3*hlm3-12 .d0*rkt2*hlm4 

c (5,  kt) *rkt4*hlm4 

go  to  399 

c . 2100  1200  0021  0012 

15  if (ni)l, 316,317  . 

316  hlml-hml 
hlm2«hm2 
hlm3*hm3 
goto308 

317  hlml-hll 
hlm2-hl2 
hlm3-hl3 
goto308 

c . 2110  2101  1210  1201  1021  1012  0121  0112 

16  if (ni+nj-nk-nl) 318, 1, 319 

318  hlml  -hi  0  *hml  +hl  1  *  hmO 
hlm2-hl 0 *hm2+hl 1 * hml 
hlm3«hll*hm2+hl0*hm3 
hlm4-hll*hm3 
goto307 

319  hlml-hl0*hml+hll*hm0 
hlm2«hl2*hm0+hll*hml 
hlm3«hl2*hml+hl3*hm0 
hlm4«hl3*hml 

go  to  307 

c . 2120  2102  1220  1202  2021  2012  0221  0212  2111  1211  1121  1112 

19  if (ni+nj-nk-nl) 320, 1, 321 

320  hlml«hl0*hml+hll*hm0 
hlm2-hl 0 *  hm2+hl 1  * hml +hl 2 *  hmO 
hlm3«hll*hm2+hl0*hm3+hl2*hml 
hlm4«hl2*hm2+hll*hm3 
hlm5-hl2*hm3 

goto322 

321  hlml«hl0*hml+hll*hm0 
hlm2»hl0*hm2+hll*hml+hl2*hm0 
hlm3«hl2*hrnl+hl3*hm0+hll*hm2 
hlm4-hl2*hm2+hl3*hml 
hlm5-hl3*hm2 

322  if  (rkt) 370, 371, 370 

371  c<l,kt)«hl0*hm0 

c(2,kt)—  2.d0*hlm2 
c (3,  kt)  «12 . d0*hlm4 
maum-3 
goto399 

370  if  (abxyz+cdxyz) 1372, 1372,  373 

1372  rkt2-rkt*rkt 
rkt3-rkt*rkt2 
rkt5-rkt2*rkt3 
c(l,kt)-0.d0 
c  (2, kt) »rkt*hlml 
c  (3, kt) “-6 . d0*rkt*hlm3 
c  (4, kt) »rkt3*hlm3+60 .dO*  rkt*hlm5 
c  (5, kt) — 20 .d0*rkt3*hlm5 
c  (6, kt) -rkt5*hlm5 
goto399 

373  continue 

rkt2-rkt*rkt 
rkt  3*  rkt*  rkt  2 
rkt4-rkt*rkt3 

IU 
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rkt5®rkt*rkt4 
c (1 , kt) -hlO*hmO 
c (2, kt) -rkt*hlml-2 . d0*hlm2 
c  (3, kt) -rkt2*hlm2-6 .d0*rkt*hlm3+12 . d0*hlm4 
c  (4,kt)-rkt3*hlm3-12.d0*rkt2*hlm4+60 ,d0*rkt*hlm5 
c  (5,  kt)  -rkt4*hlm4-20  .d0*rkt3*hln\5 
c (6, kt) -rkt5*hlm5 
go  to  399 
c . 2200  0022 

23  if <ni)l,323,324 

323  hlml-hml 
hlm2*hm2 
hlm3“hm3 
hlm4“hm4 
goto307 

324  hlml-hll 
hlm2-hl2 
hlm3«hl3 
hlm4*hl4 
goto307 

c . 2210  2201  1022  0122 

24  if (ni-n j) 325, 326, 325 

325  hlml»hlO*hml+hll*hmO 
hlm2*hll*hml+hl0*hm2 
hlm3*hll*hxn2+hl0*hm3 
hlm4*hll*hm3+hl0*hm4 
hlm5*hll*hm4 
goto322 

326  hlml~hlO*hml+hll*hmO 
hlm2»hll*hml+hl2*hm0 
hlm3»hl2*hml+hl3*hm0 
hlm4-hl3*hml+hl4*hm0 
hlm5=*hl4*hml 
goto322 

c . 2220  2202  2022  0222  2211  1122 

27  hlml*=hl0*hml+hll*hm0 

hlm2=shl0*hm2+hll*hml+hl2*hxn0 
if  (ni+n j-nk-nl) 328, 1 , 329 

328  hlm3*hml*hl2+hm2*hll+hm3*hl0 
hlm4*  hm2*hl2+hm3*hll+hm4*hl0 
hlm5i*hm3*hl2+hin4*hll 
hlm6*hm4*hl2 

goto330 

329  hlm3-hll*hm2+hl2*hml+hl3*hm0 
hlm4*hl2*hm2+hl3*hml+hl4  *hm0 
hlm5-hl3*hm2+hl4*hml 
hlm6='hl4*hm2 

330  if  (rkt)360, 1350, 360 

360  if  (abxyz+cdxyz) 1352, 1352, 1353 

1352  rkt2-rkt*rkt 
rkt4=»rkt2*rkt2 
rkt6«rkt2*rkt4 
c (1,  kt) -hl0*hm0 
c(2,kt)—  2.d0*hlm2 

c (3, kt) »rkt2*hlm2+12 . d0*hlm4 

c (4, kt) — 12.d0*rkt2*hlm4-120 .d0*hlm6 

c (5, kt) »rkt4*hlm4+180 . d0*rkt2*hlm6 

c (6, kt) — 30 .d0*rkt4*hlm6 

c (7, kt) «rkt6*hlm6 

goto399 

1353  continue 
rkt2=rkt*rkt 
rkt3-rkt*rkt2 
rkt4-rkt*rkt3 
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rkt5-rkt*rkt4 
rkt6*rkt*rkt5 
c(l,kt)-hl0*hm0 
c (2, kt) *rkt*hlml-2 . d0*hlm2 

C(3,kt)-rkt2*hltn2-6.d0*rkt*hlm3+12  .d0*hlm4 

c  (4, kt) -rkt3*hlm3-l2 .d0*rkt2*hlm4+60 . d0*rkt*hlm5-120 .dO*hln»6 
C(5,kt)«rkt4*hlm4-20.d0*rkt3*hlm5+180.d0*rkt2*hlm6 
c  (6,kt) *rkt5*hlm5-30.d0*rkt4*hlm6 
c  (7,  kt)  -rkt6*hljn6 
go  to  399 

c . 2121  2112  1221  1212 

28  hlml«hlO*hml+hll*hmO 

hlm2-hl0*hm2+hll*hml+hl2*hm0 

hlm3-hl  0  *  hm3+hl  1  *  hm2+hl  2  *  hml +hl  3  *  hmO 

hlm4“hll*hm3+hl2*hm2+hl3*hml 

hlm5-hl2*hm3+hl3*hm2 

hlm6=hl3*hm3 

goto330 

c . 2221  2212  2122  1222 

36  hlral«hll*hm0+hl0*hml 

h  lm2  *hl  0  *  hm2 +hl  1  *  hml +h  1 2  *  hmO 
hlm3-hl 0 * hm3+hl 1  * hm2 +hl 2 * hml +hl 3 * hmO 
if(ni-nj)331,332,331 

331  hlm4-hml*hl3+hm2*hl2+hm3*hll+hm4*hl0 
hlm5=hm2*hl3+hm3*hl2+hm4*hll 
hlm6«hm3*hl3+hm4*hl2 
hlm7=hm4*hl3 

goto333 

332  hlm4-hll*hm3+hl2*hm2+hl3*hml+hl4*hm0 
hlm5«hl2*hm3+hl3*hirJ2+hl4*hml 
hlm6-hl3* hm3+hl4 * hm2 
hlm7»hl4*hm3 

333  if  (rkt)1351, 1350,  1351 

1350  c(l,kt)«hl0*hm0 
c(2,kt)— 2.d0*hlm2 
c(3,kt)«12.d0*hlm4 

c  (4, kt) *-120 .d0*hlm6 

msum*4 

go  to  399 

1351  if  (abxyz+cdxyz) 366, 366, 367 

366  rkt2*rkt*rkt 
rkt3*rkt*rkt2 
rkt5-rkt2*rkt3 
rkt7-rkt2*rkt5 
c(l,kt)*0.d0 

c  (2, kt) *rkt*hlml 

c (3, kt) *-6.d0*rkt*hlm3 

c  (4, kt) «rkt3*hlm3+60 .d0*rkt*hlm5 

c  (5, kt) *-20.d0*rkt3*hlm5-840 . d0*rkt*hlm7 

c  (6, kt) *rkt5*hlm5+420 .d0*rkt3*hlm7 

c(7,kt)«- 42.d0*rkt5*hlm7 

c(8,kt)*rkt7*hlm7 

goto399 

367  continue 
rkt2«rkt*rkt 
rkt3-rkt*rkt2 
rkt4*rkt*rkt3 
rkt5*rkt*rkt4 
rkt6«rkt*rkt5 
rkt7-rkt*rkt6 

c (1, kt) «hl0*hm0 

c (2, kt) *rkt*hlml-2 . d0*hlm2 

c  (3, kt) *rkt2*hlm2-6.d0*rkt*hlm3+12 ,d0*hlm4 

C(4,kt)-rkt3*hlm3-12.d0*rkt2*hlm4+60.d0*rkt*hlm5-120.d0*hlm6 
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c  (5/  kt)  -rkt4*hlm4-20.d0*rkt3*hlm5+180  .d0*rkt2*hlm6-840  .d0*rkt*hlm7 
C(6,kt)-rkt5*hlm5-30.d0*rkt4*hlm6+420.d0*rkt3*hlm7 
c (7, kt)-rkt6*hlm6-42.d0*rkt5*hlm7 
c (8, kt) -rkt7*hlm7 
goto399 
c . 2222 

44  hlral-hlO*hml+hll*hmC 

hlm2»hlO*hm2+hll*hml+hl2*hmO 

hlm3-hl  0  *hm3+hl  1  *  hm2 +hl  2  *  hml +hl  3  *  hmO 

hlm4»hl0*hm4+hll*hm3+hl2*hm2+hl3*hml+hl4*hm0 

hlm5«hll*hm4+hl2*hm3+hl3*hm2+hl4*hml 

hlm6»hl2*hm4+hl3*hm3+hl4*hm2 

hlm7-hl3*hm4+hl4*hm3 

hlm8-hl4*hm4 

if  (rkt) 363, 362,  363 

362  c (1, kt) -hl0*hm0 

c (2, kt) — 2 .d0*hlm2 
c (3,  kt) -12 .d0*hlm4 
c (5,  kt) -1680 . dO*hlm£ 
msum-5 

c  (4, kt) — 120 .dO*hlm£ 
goto399 

363  if (abxyz+cdxyz) 364, 364, 365 

364  rkt2-rkt*rkt 
rkt4-rkt2*rkt2 
rkt6-rkt2*rkt4 
rkt8«rkt4*rkt4 
c(l,kt)-hlO*hmO 

c  (2,  kt)  — 2  .d0*hlm2 

c (3,  kt) -rkt2*hlm2+12.d0*hlm4 

c  (4, kt) — 12 .d0*rkt2«hlm4-120 .d0*him6 

c  (5,  kt)  -rkt4*hlm4  +  180  .d0*rkt2*hlm6+1680  .d0*hlm8 

c  (6,  kt)  —  30  .d0*rkt4»hlm6-3360  . d0*rkt2*hlm8 

c (7, kt) -rkt6*hlm6+8<0 .d0*rkt4*hlm8 

c  (8,  kt)— 56.d0*rkt6’hlm8 

c (9, kt) -rkt8*hlm8 

goto399 

365  rkt2-  rkt*rkt 
rkt3-rkt*rkt2 
rkt4»rkt*rkt3 
rkt5-rkt*rkt4 
rkt6-rkt*rkt5 
rkt7-rkt*rkt6 
rkt8-rkt*rkt7 

c (1, kt) -hlC*hm0 
c  (2, kt) «rkt*hlml-2 .cO*hlm2 
c  (3,  kt)  »rkt2*hlm2-6.dO*rkt*hlm3+12  .  d0*hlm4 
C(4,kt)-rkt3*hlm3-12.d0*rkt2*hlm4  +  60.d0*rkt*hlm5-120.d0*hlm6 
C(5,kt)-rkt4*hlm4-2c.d0*rkt3*hlm5+180.d0*rkt2*hlm6-840.d0*rkt*hlm7 
x+1680.d0*hlm8 

c(6,kt)-rkt5*hlm5-3C.d0*rkt4*hlm6+420.d0*rkt3*hlm7-3360.d0*rkt2*hl 

xm8 

C(7,kt)«rkt6*hlm6-42.d0*rkt5*hlm7+840.d0*rkt4*hlm8 
c (8, kt) -rkt7*hlm7-56.d0*rkt6*hlm8 
c (9,kt)-rkt8*hlm8 

399  continue 

mhi  (kt)  -msum 

346  continue 
mx-mhi  (1) 
my -mhi  (2) 
mz-mhi (3) 
mxyz-mx+my+mz-2 
if  (pqsq) 461,461,462 
f 8«xl7 
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f7-xl5 

f6-xl3 

f 5-xll 

f4-x9 

f3-x7 

f2-x5 

fl-x3 

fO-l.dO 

go  to  463 

462  t«w*pqsq 

if  (t-27.9d0)4620, 4621,4621 

4620  x-l0.d0*(t+0.05d0) 
it-x 

ti-it 

it-it+1 

delt-t-0 . Id0*ti 
delt2»0.5d0*delt 
delt3— .  33333333d0*delt 

c  correction  here  8/70-wyh-thd  got  info  from  basch 

c  delt4«.25d0*delt 

delt4— 0.25d0*delt 
tf 0-str0 (it) 
tfl-strl (it) 
tf2-str2(it) 
tf3-str3 (it) 
tf 4-str4 (it) 
tf5-str5  (it) 
tf6-str6(it) 
tf7-str7 (it) 
tf 8»str8 (it) 
tf 9-str9 (it) 
tf 10-strl0 (it) 
tfll-strll (it) 
tfl2-strl2(it) 

go  to  (800, 801, 802, 803, 804, 805, 806, 807, 808) ,mxyz 
808  f 8-tf 8+delt*  (-tf  9+delt2*  (tfl0+delt3*  (tf ll+delt4*tf 12) ) ) 
807  f7«tf7+delt*  (-tf 8+delt2*  (tf9+delt3*  (tfl0+delt4*tfll) ) ) 
806  f  6-tf  6+delt*  <-tf7+delt2*  (tf  8+delt3*  (tf 9+delt4*tf  10) ) ) 
805  f 5-tf 5+delt*  (-tf6+delt2*  (tf7+delt3*  (tf 8+delt4*tf 9) ) ) 

804  f 4«tf 4+delt* <-tf5+delt2* (tf 6+delt3* (tf 7+delt4*tf 8) ) ) 

803  f3-tf 3+delt* (-tf4+delt2* <tf5+delt3* (tf 6+delt4*tf 7) ) ) 

802  f2-tf2+delt* (-tf3+delt2* (tf 4+delt3* (tf 5+delt4*tf 6) ) ) 

801  fl-tfl+delt* (-tf2+delt2* (tf 3+delt3* (tf 4+delt4*tf  5) ) ) 

800  f 0-tf 0+delt*  (-tf l+delt2*  (tf2+delt3*  (tf3+delt4*tf 4) ) ) 
go  to  463 

4621  xd-l.dO/t 

f 0-. 88622692d0*dsqrt (xd) 
f 1*0 . 5d0*xd*f 0 
f 2-1 . 5d0*xd*fl 
f 3-2 . 5d0*xd*f2 
f4-3 . 5d0*xd*f3 
if  (mxyz.lt. 6) goto4 63 
f 5-4 . 5d0*xd*f 4 
f6«5. 5d0*xd*f5 
f 7-6 . 5d0*xd*f 6 
f 8-7 . 5d0*xd*f7 

463  continue 
zz(l)-l.d0 
zz (2) -z 

if  (mxyz-2) 380,  380, 382 
382  do  3811ife-3,mxyz 
nice-life-1 

381  zz(life)-z*zz(nice) 

380  continue 
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do390nx-l,mx 

do389ny-l,my 

do388nz-l,mz 

n-nx+ny+nz-2 

388  rawint-rawint+c  (nx,  1)  *c  (ny,  2)  *c  (nz,  3)  *zz  (n)  *f  (n) 

389  continue 

390  continue 
prtint**rawint 

540  continue 

355  valint (m) -valint <m) +wx*prtint 

351  continue 

352  continue 

353  continue 
return 
end 

subroutine  spdfnt  (eta,  valint,  s, nr, ntmx, ngmx, ninmax, nsavmx) 
illicit  double  precision  (a-h,  o-z) 

dimension  p (3) ,q (3) , r (3) ,  pa (3) ,  pb (3) , qc (3) , qd{3) , f (13) ,c{13,3) , 
lmhi (3),zz(13),e(7,3) 

dimension  eta  (ngmx,  5) ,  s  (nsavmx) ,  valint  (ninmax) ,  nr  (ntmx,  3) 
common/specs/icnt,  jcnt,  kcnt,  lent,  ityp,  jtyp,  ktyp,  ltyp,  is,  js,  ks, 
11s, if , jf ,  kf , If ,m,  i, j, k, 1 
common/nmbrs/pi,piterm, pitern,  acrcy,  scale 
common/gamma /f 0, fl,f2,f3,f4,f5,f6,f7,f8,f9,fl0,fll, fl2 
common/inc/x3, x5,x7,x9,  xll,  xl3,  xl5,xl7,xl9, x21,x23,x25 
equivalence (f (1) , fO) 
fab-l.dO 
fcd-l.dO 
abxyz-icnt- jcnt 
cdxyz-kcnt-lcnt 
abxyz-dabs (abxyz) 
cdxyz-dabs (cdxyz) 
do  353ii-is,if 
a-eta (ii, 4) 
if  (i-j) 680, 681, 680 

681  jf-ii 

fab«2.d0 

680  do  352jj»js,jf 
b-eta ( j j,4) 
tl*l .d0/ (a+b) 
gab»0. 25d0*tl 

index  -maxO (ii, j j) * (maxO (ii,  j j) -1 ) /2+min0  (ii, j j) 
saboo-s (index) 
if  (abxyz) 704, 708, 704 

704  continue 

p(l)-(a*eta (ii, 1) +b*eta ( j j,  1 ) ) *tl 
p  (2) -(a*eta (ii, 2) +b*eta ( j j,  2) ) *tl 
p(3)- (a*eta (ii, 3) +b*eta ( j j,  3) ) *tl 
go  to  709 

708  p(l) -eta (ii,  1) 
p  (2) -eta (ii, 2) 
p(3)-eta(ii,3) 

709  continue 
pa(l)-p(l)-eta(ii,l) 
pa (2)«p (2) -eta  (ii, 2) 
pa (3)-p(3) -eta (ii, 3) 
pb(l)-p(l)-eta (j j, 1) 
pb(2) «p (2) -eta ( j j, 2) 
pb(3) -p (3) -eta ( j j, 3) 
do  295kt-l, 3 
ni-nr (ityp, kt) +1 
nj-nr ( jtyp,kt)+l 
pakt-pa (kt) 
pbkt-pb(kt) 
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c  correction  here  8/70-wyh-thd  got  info  from  basch 
hlO-O.dO 
hll-O.dO 
hl2-0.d0 
hl3-0.d0 
hl4«0.d0 
hl5-0.d0 
hl6-0.d0 

go  to  (100,101,102,113)  ,ni 

10C  go  to  (103,104,105,116) ,nj 

101  go  to  (106,107,108,119) ,nj 

102  go  to  (109,110,111,122) ,nj 

113  go  to  (123,124,125,126) ,nj 

c . 00 

103  hlO-l.dO 
go  to  199 

c . 10 

106  hlO-pakt 
hi 1 “gab 
go  to  199 

c . 11 

107  hl2«gab*gab 

if (abxyz) 150, 151, 150 
151  hl0-2.d0*gab 
hll«0.d0 
gotol99 

15C  hl0«pakt*pbkt+2.d0*gab 
hi 1 -gab* (pakt+pbkt) 
go  to  199 
c . 20 

109  hl2-gab*gab 

if (abxyz) 152,153,152 
153  hl0-2.d0*gab 
gotol99 

152  hl0-pakt*pakt+2 .d0*gab 
hll-2 . d0*gab*pakt 
go  to  199 
c . 21 

110  gg-gab*gab 
hl3«gab*gg 

if  (abxyz) 154, 156, 154 

156  hll«6.d0*gg 
gotol99 

154  hl0«pakt*pakt*pbkt+2.d0*gab* (2 .d0*pakt+pbkt) 
hll«gab*pakt* (2 .d0*pbkt+pakt) +6 .  d0*gg 
hl2-gg* (2.d0*pakt+pbkt) 
go  to  199 
c . 22 

111  gg«gab*gab 
hl4«gg*gg 

if  (abxyz) 157, 159, 157 

159  hl2-12.d0*gab*gg 
hl0-12.d0*gg 
gotol99 

157  ab«pakt*pbkt 

apb- (pakt+pbkt) * (pakt+pbkt) +2 .d0*ab 
hl0«ab*ab+2.d0*gab*apb+12 .d0*gg 
hll- (pakt+pbkt) * (2 .d0*gab*ab+12 .  d0*gg) 
hl2-gg* (apb+12 . d0*gab) 
hl3-2.d0*gg*gab* (pakt+pbkt) 
go  to  199 
c . 30 

123  gg-gab*gab 
hl3-gab*gg 
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if  (abxyz) 840, 156, 840 
840  pakt2-pakt*pakt 
hl2«3 . d0*gg*pakt 
hll-3.d0*gab* (pakt2+2.d0*gab) 
hlO-pakt* (pakt2+6.d0*gab) 
go  to  199 
c . 31 

124  gg«gab*gab 
hi 4-  gg*gg 

if  (abxyz) 842, 159,  842 

842  pakt2«pakt*pakt 
pab«pakt*pbkt 

hl3-gab*gg*  (3.d0*pakt+pbkt) 
hl2-3.d0*gg* (4.d0*gab+pakt*  (pakt+pbkt) ) 

hll-gab*  (pakt2*  (pakt+3.d0*pbkt)+6.d0*gab*  (3 .dO*pakt+pbkt) ) 
hl0-pab*pakt2+6.d0*gab* (pakt2+pab) +I2.d0*gg 
go  to  199 
c . 32 

125  gg-gab*gab 
gg2«gg*gg 
hl5-gab*gg2 

if  (abxyz) 843, 844, 843 

844  hl3-20.d0*gg2 
hll-60.d0*gab*gg 
go  to  199 

843  pakt2«pakt*pakt 
pbkt  2 -pbkt  *  pbkt 
pabkt-pakt*pbkt 

hl4-gg2* (3.dO*pakt+2.dO*pbkt) 

hl3-gab*gg*  (3.d0*pakt2+6.d0*pabkt+pbkt2)+20  .d0*gg2 
hl2-gg*  (pakt*  (pakt2+6.d0*pabkt+3  .d0*pbkt2)  +gab*  (36.  d0*pakt+24  ,d0* 
xpbkt ) ) 

hll-gab*  (pabkt*  (2.d0*pakt2+3.d0*pabkt)+gab*  ( (18.d0*pakt2+36.d0*pab 
xkt+  6.d0*pbkt2)+60.d0*gab) ) 

hlO-pakt*  (pabkt *pabkt+gab*  (2.d0*pakt2+12.d0*pabkt+6.d0*pbkt2)  )  + 
x  gg* (  36.d0*pakt+24.d0*pbkt) 

go  to  199 
c . 33 

126  gg»gab*gab 
gg2-gg*gg 
hl6-gg*gg2 

if  (abxyz) 845, 846, 845 
846  hl4-30.d0*gab*gg2 
hl2-180.d0*gg2 
hi  0-1 2  0 .  dO  *gab*gg 
go  to  199 

845  pakt2-pakt*pakt 
pbkt2-pbkt*pbkt 
pabkt-pakt*pbkt 
pab-3 .dO* (pakt+pbkt) 
pkt-pakt2+3 . dO  *pabkt+pbkt2 

big-pakt2*  (pakt+9.d0*pbkt)  +pbkt2*  (pbkt+9. d0*pakt) 
hi 5-gab* gg2*pab 
hl4-gg2* (3.d0*pkt+30.d0*gab) 
hl3-gab*gg* (big+gab*20.d0*pab) 

hl2-gg*  (3.d0*pabkt*pkt+gab*  (36.d0*pkt+gab*180.d0) ) 
hll-gab*  (pab*pabkt ‘pabkt +gab*  (6.d0*big+60.d0*gab*pab) ) 
hlO-pabkt*pabkt ‘pabkt +gab*  (6.d0*pabkt*pkt+gab*  (36 .d0*pkt+120 .d0*ga 
xb) ) 

go  to  199 

c . 01 

104  hlO-pbkt 
hll-gab 
go  to  199 
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c . 02 

105  hl2-gab*gab 

if  (abxyz) 160,153, 160 
160  hl0-pbkt*pbkt+2.d0*gab 
hll-pbkt*2.d0*gab 
go  to  199 

c . 03 

116  temp-pakt 
pakt-pbkt 
pbkt-temp 
go  to  123 

c . 12 

108  gg-gab*gab 
hl3-gab*gg 

if  (abxyz) 162, 156, 162 

162  hl0-pbkt*pbkt*pakt+2.d0*gab*  (2.d0*pbkt+pakt) 
hll-gab*pbkt* (2 .d0*pakt+pbkt) +6 .  d0*gg 
hl2-gg* (2.d0*pbkt+pakt) 
go  to  199 

c . 13 

119  temp-pakt 
pakt-pbkt 
pbkt-temp 
go  to  124 

c . 23 

122  temp-pakt 
pakt-pbkt 
pbkt-temp 
go  to  125 
199  continue 
e (1, kt) -hlO 
e (2,  kt) -hll 
e(3,kt)«hl2 
e(4,kt)-hl3 
e (5, kt) -hl4 
e (6, kt) -hl5 
e(7,kt)«hl6 
295  continue 

if  (ii- j j) 431, 432,431 
432  fab-l.dO 
431  do  351kk«ka,kf 
cx-eta(kk,4) 
if  (k-1) 683, 682, 683 
682  lf-kk 
f  cd-2 .  dO 

683  do35511-ls, If 

if  (kk-11) 436, 435, 436 

435  fcd-l.dO 

436  continue 
d-eta (11,4) 
t2-l.d0/(cx+d) 
gcd-0.25d0*t2 
z-1 .d0/ (gab+gcd) 

index  -maxO  (kk,  11)  *  (maxO  (kk,  11)  -1)  /2+minO  (kk,  11) 

scdoo-s (index) 

w-0.25d0*z 

wx-piterm*daqrt  (w)  *aaboo*acdoo*f ab*fcd 

teat-2. d0*wx 

prtint-O.dO 

if  (daba (test) -acrcy) 540, 750, 750 
750  if  (cdxyz) 705, 706, 705 
705  continue 

q(l) - (cx*eta (kk, l)+d*eta (11,1)) *t2 
q(2)-(cx*eta(kk,2)+d*eta (11,2) ) *t2 
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q(3)  -  (cx*eta  <kk,  3)  +d*eta  (11,  3) )  *t2 
go  to  707 

706  q(l) -eta (kk, 1) 
q(2)  -eta  (kk, 2) 
q(3)-eta(kk,3) 

707  r (1) -p (1) -q(l) 
r  (2)-p(2)  -q(2) 
r  (3)  -p  (3)  -q(3) 

pqsq-r (1) *r (1) +r (2) *r (2) +r (3) *r (3) 

qc(l)-q(l)-eta()c)t,l) 

qc (2)-q(2) -eta (kk,  2) 

qc  (3)  -q (3)  -eta  (kk,  3) 

qd(l)-q(l) -eta (11,1) 

qd(2) -q(2) -eta (11,2) 

qd ( 3 ) -q ( 3 ) -eta (11,  3) 

if  (pqsq-1 . Od-16) 461,461,462 

461  continue 
f 12-x25 
f ll-x23 
f 10-x21 
f 9-xl9 

f 8-xl7 
f 7-xl5 
f6-xl3 
f 5-xll 
f  4-x9 
f  3-x7 
f  2-x5 
fl-x3 
fO-l.dO 
go  to  463 

462  t-w*pqsq 
y-exp(-t) 
fl2-fmch(12,t,y) 
t-2.d0*t 

f 11- (t*fl2+y) *x23 
fl0-(t*fll+y)*x21 
f 9- (t*f 10+y) *xl9 
f8-(t*f9+y) *xl7 
f 7- (t*f 8+y) *xl5 
f 6- (t*f7+y) *xl3 
f5- (t*f 6+y) *xll 
f 4- (t*f 5+y) *x9 
f 3- (t*f 4+y) *x7 
f2- (t*f 3+y) *x5 
f 1- (t*f2+y) *x3 
f0-(t*fl+y) 

463  continue 
rawint-O.dO 
do  346kt-l, 3 
ni-nr (ityp,kt) 
nj-nr ( jtyp,kt) 
nk-nr (ktyp, kt) 
nl-nr (ltyp,kt) 
msum-ni+n j+nk+nl+1 
if  (maum-l)2,2,  610 

2  c(l,kt)-l.d0 
go  to  999 

610  qckt-qc(kt) 
qdkt-qd(kt) 
rkt— r  (kt) 
hl0-e(l,kt) 
hll-e (2, kt) 
hl2-e (3, kt) 

/w 
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hl3«e(4,kt) 

hl4-e (5, kt) 

hl5-e(6,kt) 

hl6«e(7,kt) 

nk*nk+l 

nl-nl+1 

c  correction  here  8/70-wyh-thd  got  info  from  basch 
hmO-O.dO 
hml-O.dO 
hm2-0.d0 
hm3-0.d0 
hm4*»0.d0 
hm5-0.d0 
hm6*0.d0 

go  to  (200,201,202,213) ,nk 

200  go  to  (203,204,205,216) ,nl 

201  go  to  (206,207,208,219) ,nl 

202  go  to  (209,210,211,222) , nl 

213  go  to  (223,224,225,226) ,nl 

c . 00 

203  hmO-l.dO 
goto299 

c . 10 

206  hmO-qckt 
hml— gcd 
goto299 

c . 11 

207  hm2«gcd*gcd 

if (cdxyz) 250, 251, 250 
251  hm0-2.d0*gcd 
goto299 

250  hm0-qckt*qdkt+2 .d0*gcd 
hml— gcd*  (qckt+qdkt) 
goto299 
c . 20 

209  hm2«gcd*gcd 

if (cdxyz) 252, 253,  252 
253  hm0-2.d0*gcd 
goto299 

252  hm0*»qckt*qckt+2  .d0*gcd 
hml— 2 .  d0*gcd*qckt 
goto299 
c . 21 

210  gg»gcd*gcd 
hm3— gcd*gg 

if (cdxyz) 254, 256,  254 

256  hml— 6.d0*gg 
goto299 

254  hm0-qckt*qckt*qdkt+2  .d0*gcd*  (2  .d0*qckt+qdkt) 
hml—  (gcd*qckt*  (2 . d0*qdkt+qckt)  +6 .  d0*gg) 
hm2-gg* (2.d0*qckt+qdkt) 
goto299 
c . 22 

211  gg«gcd*gcd 
hm4-gg*gg 

if  (cdxyz) 257, 259,257 

259  hm2-12.d0*gcd*gg 
hm0*12.d0*gg 
goto299 

257  cd»qckt*qdkt 

cpd- (qckt+qdkt) * (qckt+qdkt)  +2 .d0*cd 
hm0-cd*cd+2 . d0*gcd*cpd+12 . d0*gg 
hml—  (qckt+qdkt)  *  (2 .d0*gcd*cd+12.d0*gg) 
hm2-gg* (cpd+12 .d0*gcd) 
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hm3— 2.d0*gg*gcd*  (qckt+qdkt) 
goto299 
c . 30 

223  gg»gcd*gcd 
hm3--gcd*gg 

if  (cdxyz}280, 256,280 
280  qckt2“qckt*qckt 
hm2-3.d0*gg*qckt 
hml“-3.d0*gcd* (qckt2+2 .d0*gcd) 
hmO-qckt* (qckt2+6.d0*gcd) 
go  to  299 
c . 31 

224  gg-gcd*gcd 
hm4-gg*gg 

if  (cdxyz)282,259,282 

282  qckt2-qckt*qckt 
qcd-qc  kt  *  qdkt 

hm3«-gcd*gg* (3.d0*qckt+qdkt) 
hm2«3.d0*gg*  (4.d0*gcd+qckt*  (qckt+qdkt) ) 

hml—  (gcd*  (qckt2*  (qckt+3.d0*qdkt)  +  6  .d0*gcd*  (3. dO* qckt+qdkt) ) ) 
hm0-qcd*qckt2+6.d0*gcd*  (qckt2+qcd)  +12  .d0*gg 
go  to  299 
c . 32 

225  gg»gcd*gcd 
gg2-gg*gg 
hm5— gcd*gg2 

if  (cdxyz)283,284,283 

284  hnt3—20  .d0*gg2 
hml«-60.d0*gcd*gg 
go  to  299 

283  qckt2«qckt*qckt 
qdkt 2 -qdkt *qdkt 
qcdkt*qckt*qdkt 
hm4-gg2*(3.d0*qckt+2.d0*qdkt) 

hm3“-  (gcd*gg*  (3 . d0*qckt2+6 . d0*qcdkt+qdkt2 )  +20 . d0*gg2) 
hm2«gg*  (qckt*  (qckt2+6.d0*qcdkt+3  .d0*qdkt2)  +gcd*  (36 . d0*qckt+24 .d0* 
xqdkt) ) 

hml»- (gcd*  (qcdkt*  (2.d0*qckt2+3.d0*qcdkt)+gcd*  ( (18 .dO*qckt2+36.dO*q 
xcdkt  +6.d0*qdkt2)+60.d0*gcd) ) ) 
hmO-qckt*  (qcdkt* qcdkt +gcd*  (2.d0*qckt2+12 .d0*qcdkt+6.d0*qdkt2) ) 
x  +gg* (  36.d0*qckt+24 .d0*qdkt) 

go  to  299 
c . 33 

226  gg-gcd*gcd 
gg2-gg*gg 
hm6«gg*gg2 

if  (cdxyz) 285, 286, 285 
286  hm4-30.d0*gcd*gg2 
hm2-180.d0*gg2 
hm0“120.d0*gcd*gg 
go  to  299 

285  qckt2»qckt*qckt 
qdkt2-qdkt*qdkt 
qcdkt *qckt  *qdkt 
cdq-3.d0* (qckt+qdkt) 
qkt-qckt2+3.d0*qcdkt+qdkt2 

big**qckt2*  (qckt+9.d0*qdkt) +qdkt2*  (qdkt+9  .d0*qckt) 
hm5— gcd*gg2*cdq 
hm4»gg2* (3.d0*qkt+30.d0*gcd) 
hm3“- (gcd*gg* (big+gcd*20.d0*cdq) ) 
hra2-gg*  (3.d0*qcdkt*qkt+gcd*  (36.d0*qkt+gcd*180.d0) ) 
hml“-  (gcd*  (cdq*qcdkt*qcdkt+gcd*  (6.d0*big+60.d0*gcd*cdq) ) ) 
hmO-qcdkt*qcdkt*qcdkt+gcd*  (6.d0*qcdkt*qkt+gcd*  (36.d0*qkt+120.d0*gc 
xd) ) 
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go  to  299 
c . 01 

204  hmO-qdkt 
hml— gcd 
goto299 

c . 02 

205  hm2»gcd*gcd 

if  (cdxyz) 260, 253,260 

260  hmO-qdkt *qdkt+2.d0*gcd 
hml— 2 .  d0*gcd*qdkt 
goto299 
c ......  03 

216  temp-qckt 
qckt-qdkt 
qdkt-temp 
go  to  223 
c . 12 

208  gg-gcd*gcd 
hm3— gcd*gg 
if  (cdxyz) 262, 256, 262 

262  hm0»qdkt*qdkt*qckt+2.d0*gcd*  (2 . d0*qdkt+qckt) 
hml—  (gcd*qdkt*  (2.d0*qckt+qdkt) +6.d0*gg) 
hm2-gg* (2.d0*qdkt+qckt) 
go  to  299 
c . 13 

219  temp-qckt 
qckt-qdkt 
qdkt-temp 
go  to  224 
c . 23 

222  temp-qckt 
qckt-qdkt 
qdkt-temp 
go  to  225 

299  continue 

hlm0-hl0*hm0 
c (1, kt)-hlm0 
hlml -hi 0 *hml +hl 1 * hmO 
c  (2, kt)-rkt*hlml 
if  (m3um-2)  999,  999, 802 

802  continue 

hlm2-hl 0 *hm2+hl 1  * hml +hl 2 * hmO 
c(2,kt)-c(2,kt)  -2.d0*hlm2 
rkt2-rkt*rkt 
c  (3, kt) -rkt2*hlm2 
if  (msum-3)  999, 999, 803 

803  continue 

hlm3-hl  0  *hm3+hl  1  *  hm2+hl  2  *  hml +hl  3  *  hmO 
c(3,kt)-c(3, kt) -6.d0*rkt*hlm3 
rkt3-rkt*rkt2 
c  (4 , kt) -rkt3*hlm3 
if  (msum-4)  999, 999,804 

804  continue 

hlm4-hl0*hra4+hll*hm3+hl2*hm2+hl3*hml+hl4*hm0 

c(3,kt)-c(3,kt)+l2.d0*hlm4 

c  (4, kt) -c(4,  kt) -12.d0*rkt2*hlm4 

rkt4-rkt*rkt3 

c(5,kt)-rkt4*hlm4 

if  (msum-5)  999,  999,  805 

805  continue 

hlm5-hl5*hm0+hl4*hml+hl3*hm2+hl2*hm3+hll*hm4+hl0*hm5 
c(4,kt)-c(4,kt) +60.d0*rkt*hlm5 
c  (5, kt) -c(5, kt) -20.d0*rkt3*hlm5 
rkt5-rkt*rkt4 
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c (6, kt) «rkt5*hlm5 
if  (msum-6) 999, 999, 806 

806  continue 

hlm6-hl  6  *  hmO+hl  5  *  hml +hl  4  *  hm2 +hl  3  *  hm3+hl  2  *  hm4 + hi  1  *  hm5+hl  0  *  hm6 

c  (4,  kt)  -c  (4,  kt)  -120.d0*hlm6 

c(5,kt)-c(5,kt)+180.d0*rkt2*hlm6 

c (6, kt) -c (6, kt) -30.d0*rkt4*hlm6 

rkt6-rkt*rkt5 

c (7,  kt) -rkt6*hlm6 

if  (ntsum-7) 999, 999, 807 

807  continue 

hlm7-hll*hjn6+hl2*hm5+hl3*hm4+hl4*hm3+hl5*hin2+hl6*hml 

c (5,  kt) -c (5, kt) -840.d0*rkt*hlm7 

c  (6,  kt)  -c  (6, kt) +420 .d0*rkt3*hlm7 

c  (7,  kt)  -c  (7,  kt) -42 .d0*rkt5*hlm7 

rkt7«rkt*rkt6 

c (8, kt) «rkt7*hlm7 

if  (msuro-8)  999,  999, 808 

808  continue 

hlm8«hl2*hm6+hl3*hm5+hl4*hm4+hl5*hm3+hl6*hm2 
c  (5,  kt)  -c  (5, kt) +1680 .d0*hlm8 
c  (6,  kt)  «c  (6,  kt) -3360 .d0*rkt2*hlm8 
C(7,kt)-c(7,kt)+840.d0*rkt4*hlm8 
c  (8,  kt) -c  (8, kt) -56.d0*rkt6*hlm8 
rkt8«rkt*rkt7 
c (9, kt) «rkt8*hlm8 
if  (msum-9) 999, 999, 809 

809  continue 

hlm9«hl3*hm6+hl4*hm5+hl5*hm4+hl6*hm3 
c (6, kt) -c (6, kt) +15120. d0*rkt*hlm9 
c (7, kt) -c (7,kt) -10080. d0*rkt3*hlm9 
c (8, kt)-c (8,kt)+1512.d0*rkt5*hlm9 
c  ( 9 ,  kt )  «c  ( 9 ,  kt )  -72 .  dO*  rkt  7  *hlm9 
rkt9-rkt*rkt8 
C  (10, kt) -rkt9*hlm9 
if  (maum-10) 999, 999, 810 

810  continue 

hlml  0 -hi 4  * hm6+hl 5* hm5+hl 6 *  hm4 
c (6, kt) -c (6, kt) -30240. d0*hlml0 
c (7, kt) -c (7, kt) +75600.d0*rkt2*hlml0 
c (8, kt) -c (8, kt) -25200. d0*rkt4*hlml0 
c (9, kt) -c (9, kt) +2520 .d0*rkt6*hlml0 
c (10, kt) -c (10, kt) -90 .d0*rkt8*hlml 0 
rktl0-rkt*rkt9 
c (11, kt) -rktlO*hlmlO 
if  (msum-11) 999, 999, 811 

811  continue 
hlmll«hl5*hm6+hl6*hm5 

c (7, kt) -c (7, kt) -332640 .dO* rkt *hlmll 
c (8, kt) -c (8, kt) +277200 .d0*rkt3*hlmll 
c (9, kt) -c (9, kt) -55440.d0*rkt5*hlmll 
c (10, kt) -c (10, kt) +3960.d0*rkt7*hlmll 
c (11, kt) -c (11, kt) -110.d0*rkt9*hlmll 
rktll«rkt*rktlO 
c (12, kt) -rktll*hlmll 
if  (msum-12) 999, 999, 812 

812  continue 
hlml2-hl6*hm6 

c (7, kt) -c (7, kt) +665280.d0*hlml2 
c (8, kt) »c(8, kt) -1995840. d0*rkt2*hlml2 
c (9, kt) -c (9, kt) +831600.d0*rkt4*hlml2 
c (10, kt)-c (10, kt) -110880. d0*rkt6*hlml2 
c (11, kt) -c (11, kt)+5940.d0*rkt8*hlml2 
c (12, kt) «c (12, kt) -132.dO*rktlO*hlml2 
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rktl2-rkt*rktll 
c(13,kt)-rktl2*hlml2 
999  continue 

mhi (kt) -msum 

346  continue 
mx-mhi  (1) 
my-mhi (2) 
m2 -mhi (3) 
mxy z-mx+my +mz - 2 
zz(l)-l.dO 

22(2)-Z 

if  (mxyz-2)380,380,382 
382  do  3811ife-3,mxyz 
nice-life-1 

381  zz (life) =z*zz (nice) 

380  continue 

do390nx«l,mx 

do389ny-l,my 

do388nz-l,mz 

n-nx+ny+nz-2 

388  rawint-rawint+c (nx,l) *c (ny,  2)  *c(nz, 3) *zz  (n) *f (n) 

389  continue 

390  continue 
prtint-rawint 

540  continue 

355  valint (m)  -valint (m) +wx*prtint 

351  continue 

352  continue 

353  continue 
return 
end 

subroutine  gfunct  (l,m,  a,  b,  p, t, g, n) 
implicit  double  precision <a-h, o-z) 
dimension  g(7,3) 

11-1+1 

mm«m+l 

go  to  (100, 101, 102,103),  11 

100  go  to  (110, 111, 112, 113), mm 

101  go  to  (120, 121, 122, 123), mm 

102  go  to  (130,131, 132,133) ,mm 

103  go  to  (140, 141, 142, 143), mm 

c . 00 

110  g(l,n)-l.d0 
go  to  300 

c . 01 

111  g(l,n)-b 
g(2,n)— p 
go  to  300 

c . 02 

112  g (1, n) «b*b+0 . 5d0*t 
g(2,n)—  2.d0*b*p-0.5d0*t 
g(3,n)  -p*p 

go  to  300 
c . 03 

113  teirp-a 
a-b 
b-temp 
go  to  140 

c . 10 

120  g (1, n) -a 
g(2,n)— p 
go  to  300 

c . 11 

121  g(l,n)«a*b+0.5d0*t 

IS* 
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g(2,n) — p* (a+b) -0. 5d0*t 
g(3,n)«p*p 
go  to  300 
c . 12 

122  g(l,n)-b*b*a+0.5d0*t* (a+2.d0*b) 

g  (2,  n)  — p*b* (2.d0*a+b) -0.5d0*t* ( (a+2 .d0*b) +3 .d0*p) 
g (3, n) «p* (p* (a+2.d0*b)+1.5d0*t) 
g(4,n)— p*p*p 
go  to  300 
c . 13 

123  temp-a 
a-b 

b«temp 
go  to  141 
c . 20 

130  g(l,n)-a*a+0.5d0*t 

g (2, n) — 2 .d0*a*p-0 . 5d0*t 
g(3,n)«p*p 
go  to  300 
c . 21 

131  g(l,n)«a*a*b+0.5d0*t* (2.d0*a+b) 

g(2,n)«- p*a* (a+2.d0*b)  -0.5d0*t* ( (2 . d0*a+b) +3 . d0*p) 
g (3, n) «p* (p* (2 .d0*a+b) +1 . 5d0*t) 
g(4,n) »-p*p*p 
go  to  300 
c . 22 

132  aa«a*a 
bb-b*b 

PP-P*P 

ab-4.d0*a*b 

g(l,n)«aa*bb+t* (0.5d0* (aa+ab+bb) +0 . 75d0*t) 

g(2,n)«- (2.d0*p*  (aa*b+a*bb)  +t*  (0.5d0*  (aa+ab+bb) +3.  dO*  (a+b)  *p+1.5 
xd0*t) ) 

g(3,n)«pp*  ( (aa+ab+bb)  +3. dO *t )  +t*  (3.d0*p*  (a+b)  +0 . 75d0*t) 
g(4,n)«- (pp*  (2.d0*p*  (a+b) +3 . d0*t)  ) 
g(5,n)-pp*pp 
go  to  300 
c . 23 

133  temp»a 
a-b 

b-temp 
go  to  142 
c . 30 

140  g(l,n)«a* <a*a+l . 5d0*t) 

g(2,n)— 3.d0* (a* (a*p+0. 5d0*t) +0. 5d0*p*t) 
g(3,n) «3.d0*p* (a*p+0 . 5d0*t) 
g(4,n)—  p*p*p 
go  to  300 
c . 31 

141  p2«p*p 
t2»t*t 
a2»a*a 
ab-a*b 
f0-a2*ab 
fl-a2*(a+3.d0*b> 
f2-3.d0*a* (a+b) 
f3-3.d0*a+b 

g(l,n)-f0+.5d0*t*f2+.75d0*t2 
g(2,n) — (p*fl+. 5d0*t*f 2+1 . 5d0*p*t*f 3+1 . 5d0*t2) 
g(3, n) -p2*f2+l . 5d0*p*t*f 3+3 .d0*t*p2+ . 75d0*t2 
g(4,n)  —  (p*p2*f  3+3.d0*t*p2) 
g(5,n) -p2*p2 
go  to  300 
c . 32 

if/ 
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142  p2-p*p 
a2-a*a 
b2-b*b 
ab-a*b 
t2«t*t 

a3«3 . d0*a2+6. d0*ab+b2 
al-a2+6 . d0*ab+3 . d0*b2 

g<l,n)«a*a2*b2+0.5d0*t*al*a+0.75d0*t2* (3.d0*a+2.d0*b) 
g(2,n)«- <ab*p* (2 .d0*a2+3 .dO*ab) +0 . 5d0*t*a*al+l . 5d0*t*a3*p+l . 5d0*t2 
x*  (3. d0*a+2 .d0*b) +3 . 75d0*p*t2) 

g(3,n)-p2*a*al+1.5d0*p*t*a3+3.d0*  <3 .  d0*a+2 ,dO*b)  *  <t*p2+.25d0*t2)+7 
x. 5d0*p*t2 

g (4, n) «- (p2* (p*a3+t* (9 .  d0*a  +  6 .d0*b) +5 .d0*p*t ) +3 . 75d0*p*t2) 
g (5, n) «p*p2* (p* (3.dO*a+2.dO*b)+5.dO*t) 

g (6, n) =-p*p2*p2 

go  to  300 
c . 33 

143  p2«p*p 
a2=a*a 
b2»b*b 
t2-t*t 
ab-a*b 

f 0=a2*b2*ab 
fl-3.d0*a2*b2* (a+b) 
f2«3.d0*ab*(a2+3.d0*ab+b2) 
f 3=a2* (a+9.d0*b) +b2* (b+9.d0*a) 
f4«3.d0* (a2+3.d0*ab+b2) 
f5-3.d0*(a+b) 

g (1 / n) «f 0+ . 5d0*t*f 2+ . 75d0*t2*f 4+1 . 875d0*t*t2 

g  (2,  n)  (p*f  1+ .  5d0*t*f 2+1 . 5d0*t*p*f 3+1 . 5d0*t2*f 4+3 . 75d0*p*t2*f 5+5 . 
x625d0*t*  t2) 

g  (3, n)  «p2*f2+l .  5d0*p*t*f 3+3 ,dC*f 4*  <t*p2+ .  25d0*t2)  +7 . 5d0*p*t2*f5+ll 
x . 25d0*t2*  (.5d0*t+p2) 

g(4,  n)  — (p2*  (p*f3+3.d0*t*f4)  +5 . d0*f 5*p*t*  (p2+ .  75d0*t)  +t2*  (22.50d0* 
xp2+1.875d0*t) ) 

g (5,  n)  =p2*  (f4*p2+5.d0*p*t*f5+7 . 5d0*p2*t+ll . 25d0*t2) 
g (6, n) *- (p2*p2* (p*f5+7 . 5d0*t) ) 
g (7, n) -p2*p2*p2 
300  continue 
return 
end 

double  precision  function  tanh3{x) 
implicit  double  precision (a-h, o-z) 
c  tanh (x) -x* (1 . 0+tanh3 (x) ) 

z»x*x 

tanh3--z*0 . 33333333333 3 33 33d0* (1 . 0d0-z*0 . 4d0*  (l.OdO- 

#  z*0.4047619047619048d0* (1 . 0dC-z*0 . 4052287581699345d0*  <1.0d0- 
«  z*0. 40 5278592 3753667d0* (1 . 0dC-z*0 . 4052840550669783d0* (1.0d0- 

#  z*0. 40 52 846591 850437d0* (1 . 0d0-z*0 . 4052847261979033d0*  (l.OdO- 

#  z*0.4052847336393726d0* (1 . 0d0-z*0 . 4052847344660274d0* (l.OdO- 

#  z*0 . 4052847345578709d0) ))))))))) 
return 

end 

double  precision  function  fa (n) 
c 

implicit  double  precision (a-h, o-z) 
c  n.le.ll 

dimension  gamroo (6) , gamme  (6) 
common/aaacom/zeta 

data  gammo/0. 5d0, 0. 5d0, 1 .d0, 3.d0, 12 .d0, 60 . d0/,gamme/0 . 5d0,  0 . 25d0, 
xO.  375d0,  0. 9375d0,  3. 28125d0, 14 .76562 5d0/,  sqrpi/l .  7724 538 5090d0/ 


c 


if  (mod<n, 2) .eq.0)gotol0 
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k-(n-l)/2 

fa-gammo  (k+1)  /zeta**  <k+l) 
return 

10  k^n/2 

gms-gamme  (k+1)  *sqrpi 
fa-gms/ (zeta**k*dsqrt (zeta) ) 
return 
end 

subroutine  wnrval  (itype,  n,x,  vm,  v) 
c  version  #1  may  9,  1985  c. woodward 
implicit  double  precision <a-h, o-z) 
parameter (syslim-88. OdO) 
common/erfp/dk,xi j 
data  srpi/1 . 77245385090d0/ 
if  ( itype. gt.l)goto20 
go  to  (1,2,  3,  4,5,6),  n 
if (n.ne. 0) gotolOO 
c 

c  n~0 

call  dawv (daws, daws3,x) 
vm**2 . 0d0*daws*srpi 
if (itype. eq. 0) return 
if (x.lt.0.3d0)gotoll 
v«=  srpi-vm/  (2 . 0d0*x) 
return 

11  v»-srpi*daws3 
return 

c 

c  n-1 

1  call  errv  (errf , errf3, x, ex2,  z) 
vm=2 . 0d0*errf 

if  ( itype. eq. 0) return 
if  (x.lt.0.3d0)goto21 
x2~x*x 

v  « (x-0 . 5d0/x) *vm+exp (-x2) 
return 

21  v»ex2* (z+ (z-1 . OdO) *errf 3) 
return 
c 

c  n*=2 

2  vm  -srpi*x 

if (itype .eq. 0) return 
v  «x*  vrti 
return 
c 

c  n-3 

3  call  errv(errf,errf3,x,ex2,  z) 
vml,«2 . 0d0*errf 

if  (x. It. 0. 3d0)goto31 
x2-x*x 

v2* (x-0 . 5d0/x) *vml+exp (-x2) 
go  to  32 

31  v2«ex2* (z+ (z-1 . OdO) *errf3) 

32  continue 

vm**  x*v2+vml 
v- (x2+0 . 5d0) *v2+x*vml 
return 
c 

c  n-4 

4  x2»x*x 

vm  «srpi*x* (x2+1.5d0) 
if (itype .eq. 0) return 
v  -srpi*x2* (x2+2 . ~  10) 
return 


I 


lopas . sub 


Fri  Apr  5  11:22:53  1991 


76 


5  call  errv(errf,errf3,x,ex2,  z) 
x2«x*x 

if  (x.lt.0.3d0)goto42 

vm-  (0 . 75d0+x2* (3. 0d0+x2) )*2 . 0d0*errf+x* (x2+2 . 5d0) *exp (-x2) 
v- (-0 . 375d0+x2* (2 .25+x2* (4 . Sd0+x2) ) ) *2 . 0d0*errf /x+ 

#  { 0 . 75d0+x2* ( 4 . 0d0+x2 ) ) *exp { -x2 ) 
return 

42  vm-2 . 0d0*x*exp (-x2) * ( (0 . 75d0+x2* {3 . 0d0+x2) ) *errf 3+ 

#  2 . 0d0+x2  * ( 3 . 5d0+x2 ) ) 

v-2 . 0d0*exp (-x2) * ( (-0 . 375d0+x2* (2 . 25d0+x2* (4 . 5d0+x2) ) ) * 

#  errf 3+x2* (4.25d0+x2* (5.0d0+x2) ) ) 
return 

n*6 

6  x2*x*x 

vm»srpi*x* (3.75d0+x2* (5. 0d0+x2) ) 
if  (itype.eq.O) return 
v»srpi*x2* (8 . 75d0+x2* (7 . 0d0+x2) ) 
return 

integrals  involving  the  error  function 

>0  srxi  j=*dsqrt  (xi  j) 
dks*dk*dk 
x2=x*x 
exa*0 . OdO 

if  (x2  .  It.syslim)exa=*exp(-x2) 
call  errv(errf,errf3,x,ex2, z) 

goto  (100,120,100,130) , n-2 


v*errf/ (2 . 0d0*dk*srxi j) 
vm= (exa*x*xi j+errf * (2 . OdO* dks -xi j) ) / 
I  (4 . 0d0*dks*xi j*srxi j) 

return 


xi js-xi j*xi j 

v- (xi j*exa*x* (2 . OdO-xi j*x*x/dks) + 

#  errf *  (2 . 0d0*dks+xi j) ) / 

#  (4 . 0d0*dk*xi js*srxi j) 

vm-  (exa*xi j*x* (6. 0d0*dks+xi j+ 

#  x*x*xi j* (2. 0d0*xi j*x*x/dks-6 . OdO) )  + 

#  errf*(4.0d0*dks* (dks+xi j) 

#  -xi js) )/ (8. 0d0*xi js*xi j*srxi j*dks) 
return 


L30  v- (exa*x*xi j* (8 . 0d0*dks+12 . 0d0*xi j 
f  +x*x*xi j* (-12 . 0d0-10 . 0d0*xi j/dks+ 

#  x*x*xij*  (8.0d0+xij*  (3. OdO-2 . 0d0*x*x)  /dks)  /dks) )  + 

#  errf * (3. 0d0*xi j*xi j+12 . 0d0*xi j*dk*dk+ 

#  4 . 0d0*dk**4 .  OdO) )  /  (8 . 0d0*xi  j*xi  j*xi  j*xi  j*srxi  j*dk) 
return 

100  write(60,101)itype,n 

101  format (lhl,'  ***  itype  -',i3,'  n  ,i3,'  for  vval') 
stop 

end 
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subroutine  dawv (daws,daws3,xx) 
implicit  double  precision (a-h, o-z) 
common/dawson/da (1000) 

common/dawsf /al, a2, a3,  a4,  a5, a6, a7,  a8, a9,  alO, all, al2, al3, al4, al5 
«  , al6, al7 

if (xx) 1, 30,2 

1  x— xx 
3— l.OdO 
go  to  3 

2  x»xx 
s-l.OdO 

3  if (x . It . 0 . 3d0 ) goto4  0 
if  (x-9 . 995d0) 10,20,20 

c  x  less  than  9-995 
10  a-100 . 0d0*x 
j»a+0 . 5d0 

1-j+l 

blOO-j 

b-.01d0*bl00 

d“X-b 

d2«d*2.0d0 
cO-da (1) 

cl«d* (1 . 0d0-2 . 0d0*b*c0) 

c2— d2*  (b*cl+d*c0)  *0 . 5d0 

c3— d2* (b*c2+d*cl) *0 . 33333333333333d0 

c4— d2*  (b*c3+d*c2)  *0.25d0 

c5— d2*  (b*c4+d*c3)*0.2d0 

daws- (c0+cl+c2+c3+c4+c5) *s 

return 

c  x  greater  than  9.995 

20  xi-0.5d0/x 
xi2«xi*xi 

daws-xi* (1 . 0d0+xi2* (2 . 0d0+xi2* (12 . OdO+xi2* (120 . 0d0+xi2* 

#  1680 . OdO) ) ) ) *s 
return 

30  daw3=0.0d0 
daws3-0 . OdO 
return 

40  z«2.0d0*x*x 

daws3— z*a3* <1.0d0-z*a5* (1. 0d0-z*a7* (1.0d0-z*a9 

#  * (1 . 0d0-z*all* (1 . 0d0-z*al3* (1 .  OdO-z*al5* (1 . 0d0-z*al7) )))))) 
daws-xx* (1 . 0d0+daws3) 

return 

end 

subroutine  errv (errf , errf 3, xx, ex2, z) 
implicit  double  precision (a-h, o-z) 
common/errf un/err (550) 

common/dawsf /al,  a2,a3,  a4,  a 5, a6,  a7,  a8,a9,al0,all,al2,al3,al4,al5 
»  , al6, al7 

if  (xx) 1,40, 2 

1  X— XX 

s— l.OdO 
go  to  3 

2  x-xx 
s-l.OdO 

3  if  (x.lt.0.3d0)goto30 
if (x.gt -5.495d0)goto20 

10  a-100. 0d0*x 
j-a+0.5d0 
1-j+l 
blOO-j 

b-.01d0*bl00 

d-x-b 
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exb-exp (-b*b) 
yO-err (1) 
yl-exb 
y2— b2*yl 

y3— b2*y2-2.0d0*yl 
y4— b2*y3-4 . 0d0*y2 

errf-(yO+d* (yl+a2*d* (y2+a3*d* (y3+a4*d*y4) ) ) )  *s 
return 

20  errf-0 . 886226925453d0*s 
return 

30  z-2.0d0*x*x 
ex2-exp (-x*x) 

errf 3-z*a3* (1 . 0d0+z*a5* (1 . 0d0+z*a7* {1 . OdO+z*a9 
#  *  (1 . 0d0+z*all* (1.0d0+z*al3* (1 . 0d0+z*al5* (1 . 0d0+z*al7) )))))) 
errf-ex2*xx* (1 . OdO+errf 3) 
return 

40  errf-0. OdO 
z-O.OdO 
errf 3*0 . OdO 
ex2-0. OdO 
return 
end 
c 

subroutine  locpot (noc, lpskip,  ncmx) 
c  this  subroutine  reads  the  local  potential  data  into  three 

c  arrays  [nip, clp, zip] ,  it  also  records  which  sites  use  ef- 

c  fective  potentials  while  keeping  track  of  duplications [lpskip] 

c  in  the  arrays  nip, clp, zip  each  angular  momentum  potential 

c  is  sandwiched  between  two  core  potentials  of  the  same  type, 

c  this  is  done  to  facilitate  number  crunching,  notice  this  also 

c  makes  it  neccesary  to  label  the  index  of  nlp,ect  with  several 

c  indices. . .thus  we  have  lstpl , lstp2, . . . see  below, 

c 

c  lstp4  ldsp3  lstp3  ldsp2  lstp2  ldspl  lsptl 

c  !core  !  1-3  !  core  !  1*2  !  core  !  1-1  !  core  !  ...next  input, 

c  lstr4  ldsr3  ldsr2  ldsrl 

c  lstr3  lstr3  lstrl 

c 

implicit  double  precision (a-h, o-z) 
dimension  lpskip (ncmx) 
character* 8tlp, tlopot, void, title 
common/lptyp/tlopot (1024) 

common/ int2/nlp (200) ,  clp (200) ,  zip (200) , lstrl (20) , lstr2 (20) , 

1  lstr3 (20) , lstr4 (20) ,  lstpl  (20)  ,lstp2 (20) ,lstp3 (20) ,lstp4 (20) , 

1  ldsrl (20) , ldsr2 (20) ,  ldsr3 (20) ,  ldspl (20) , ldsp2 (20) , ldsp3  (20) , 

1  dsmx (20) ,dpmx (20)  ,ddmx (20)  ,xmax (20) ,lmax  (20) 
data  void/'  '/ 

lsp-0 
xmx*0.0d0 
n-0 

do  900k-l,noc 
tlp-tlopot (k) 
lpskip (k)-0 

if (tip. eq. void) goto900 
n-n+1 

if (n.gt.20)goto998 
lpskip (k) *n 
if (k . eq . 1 ) gotol 50 
kl-k-1 

do  120kk-l, kl 

if (tip. eq. tlopot (kk) )gotol30 
120  continue 
go  to  150 

130  lpskip (k) -lpskip (kk) 
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n-n-1 
go  to  900 
150  continue 
ilsp-lsp 
nbf 4-0 
nbf 3-0 
nbf 2-0 

read  (5, 1004, end-999) title 

if  (title. eq. void) goto999 

read ( 5 , 1 0  0  7 ) lmx , dsmax , dpmax , ddmax 

if (dsmax. eq. 0 . OdO) dsmax-210 . OdO 

if (dpmax. eq. 0 . OdO) dpmax-9000 . OdO 

if (ddmax. eq. 0 . OdO) ddmax-12000 . OdO 

write (60, 1005) title 

write (60, 1008) lmx, dsmax,  dpmax, ddmax 

ddmx (n) “ddmax 

dsmx (n) “dsmax 

dpmx ( n ) “dpmax 

xmax  (n)  -xmx 

lmax  (n)-lmx 

read (5, 1004) title 

read (5, 1000) nbf 4 

lst-lsp+1 

lsp«lsp+nbf4 

read(5,1001) (nlp( j) ,zlp( j)  ,clp( j) , j=lst,lsp) 
write (60, 1010) title 

write (60,1003)  (nip ( j) ,  zlp( j)  , clp ( j) , j-lst, lsp) 
lstr4 (n) “1st 
lstp4 (n)-lsp 
go  to (230, 215, 200) ,  lmx 
200  read(5, 1004) title 
read(5,1000)nbf3 
lst*lsp+l 
lsp-lsp+nbf 3 

read (5, 1001) (nip ( j) , zlp( j) ,  clp ( j ) , j«lst, lsp) 
write (60, 1010) title 

write  (60, 1003)  (nip ( j) ,  zip ( j)  ,  clp ( j) , j=lst, lsp) 

lstr3  (n) “1st 

ldsr3 (n)“lst 

lstp3 (n) “lsp+nbf 4 

ldsp3 (n) “lsp 

do  217 j j“l,nbf4 

j“lsp+jj 

nlp( j)-nlp(ilsp+ j j) 
zlp( j)-zlp(ilsp+j j) 
clp ( j ) -clp (ilsp+ j j ) 

217  continue 

lsp-lsp+nbf4 
215  read(5,l004)title 
read  (5, 1000) nbf 2 
lst-lsp+1 
lsp-lsp+nbf2 

read (5, 1001) (nlp( j) , zlp( j) ,  clp( j) , j-lst, lsp) 
write  (60,1010) title 

write  (60,1003) (nlp( j) ,  zlp( j) ,  clp( j) , j-lst, lsp) 

ldsr2 (n)-lst 

lstr2 (n)-lst 

ldsp2 (n)-lsp 

lstp2 (n) -lsp+nbf 4 

do  220 j j-l,nbf4 

j-lsp+jj 

nip ( j) -nlp(ilsp+ j j) 
rip ( j ) —zip (ilsp+  j  j ) 
clp ( j ) —clp (ilsp+  j  j ) 
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220  continue 

lsp-lsp+nbf 4 
230  read  (5, 1004) title 
read (5, 1000) nbf 1 
lst-lsp+1 
lsp-lsp+nbfl 

read (5, 1001)  <nlp( j) ,  zip ( j ) , clp ( j ) , j-lst,lsp) 
write (60, 1010) title 

write (60, 1003)  (nlp( j)  ,  zip ( j) , clp < j ) , j-lst, lap) 

ldsrl (n) -1st 

lstrl (n) -1st 

ldspl (n) -lsp 

lstpl (n) -lsp+nbf 4 

do  240jj-l,nbf4 

j-lsp+jj 

nlp( j) -nip (ilsp+ j j) 
zip (j) —zip (ilsp+jj) 
clp( j)-clp(ilsp+ j j) 

240  continue 

lsp-lsp+nbf 4 
900  continue 
c 

do  lllm»l,n 

write (60, 2000)  lstrl  (m) ,  lstr2  (m) ,  lstr3 (m) , lstr4 (m) , lstpl (m) , 

1  lstp2  <m) , lstp3 (m) , lstp4 (m) ,  ldsrl (m) , ldsr2 (m) , ldsr3 (m) , ldspl (m)  , 

1  ldsp2  (m) ,  ldsp3  (m) ,  dsmx  (m) ,  cpmx  (m)  ,  ddmx  (m)  ,  lmax  (m) 

111  continue 

do  115m-l, lsp 

write (60, 2005)  m, nip (m)  ,clp(=0  ,  zip  (m) 

115  continue 

do  117m-l,  20 

wri _e (60, 2007) lpskip (m) 

117  continue 

20CC  format  (lx, i2, 4x, i2, 4x, i2, 4x, i2, /, lx,  i2, 4x,  i2, 4x,  i2,  4x,  i2,  /  ,  lx,  i2, 
1  4x,i2,4x, 

1  i2,  / ,  lx,i2, 4x,i2,4x,i2,/,lx,f7.1,f7.1,f7.1,i4) 

20C5  format  (2i4, 3x, dl5 . 8, 4x, dl5 . 8 ) 

2007  format (lx, i2) 
c 

return 

998  write (60,1030) 
stop 

999  write (60, 1020) 
stop 

1000  format.  (8i5) 

1001  format (il, 14x, dlO . 4, dl9 . 12) 

1003  forma: (  lx, il, 14x, dlO . 4, 2x, dl9 . 12> 

1004  format (8a8) 

1005  format (' llocal  potential  data  -  ',8a8///) 

1007  format (i5, 3dl5. 8) 

1008  format (6x, 'lmax  -' , i2 , 5x, ' dsmax  =' ,dl5. 8, 5x, 'dpmax  -',dl5.8,5x, 

1  'ddmax  -',dl5.8) 

1010  format (//lx, 8a8/) 

1020  format (//10x, '  **  missing  local  potential  data  **'/) 

1030  format (//10x, '  **  more  than  20  different  local  potentials  **') 
2400  format (lx, 'enter  the  name  of  the  polyin  input  file  (file  5)') 
21024  format(al6) 

2600  format (lx, 'enter  the  name  of  the  polyin  information  output 
1  file  (file  6)') 
end 

subroutine  vints  (noc, vlist, ntype, nr, nf irst, nlast, 

$  eta, nfmx, ncmx, ntmx, ninmax, ngmx) 

implicit  double  precision  (a-h,o-z) 
integer*2  iil  (1024) , jjl (1024) , itgl (1024) 
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dimension  ntype  (nfmx) ,  eta  (ngmx,  5) ,  nf  irst  (nfmx) ,  nlast  (nfmx) , 

1  valint (1024) , nr (ntmx, 3) , vlist (ncmx, 4) 
l,g<7,3),f  (13) 
dimension  lpskip(300) 

common/comfmch/pi4,ap0, apl, ap2, ap3, ap4, apS, ap6 

common/test/ddtest 

commonvalint 

common/gamma/f 0, fl,f2,f3,f4,f5,f6,f7,f8,f9,fl0,fll,fl2 
common/inc/x3, x5, x7, x9,  xll,  xl3,  xl5, xl7, xl9, x21, x23, x25 
common/ioind/icon (10) 

common/namtap/nitape, lstnam, notape, intnam 
common/nmbrs/pi, piterm,  pitern,  acrcy, scale,  icanon 
common/int2/nlp (200) , clp (200) ,  zip (200) , lstrl (20) , lstr2 (20) , 

1  lstr3 (20) , lstr4 (20) ,lstpl (20)  ,lstp2 (20) ,  lstp3 (20) , lstp4 (20) , 

1  ldsrl (20) , ldsr2 (20) , ldsr3 (20) ,  ldspl (20) ,  ldsp2 (20) ,ldsp3 (20) , 

1  dsmx (20) , dpmx (20) , ddmx (20) , xmax (20 ) , lmax (20) 
common/bfcom/xint, ityp, jtyp,  a,b,  nc, idum, avx, avy, avz, av,bvx,bvy,bvz 
#  , bv, pcx, pcy, pcz, pcsq, phase, charge 
equivalence (f 0, f (1 ) ) 
pi4«dsqrt (pi/4 . OdO) 
ddtest-0 . OdO 

call  locpot (noc, lpskip, ncmx) 

call  dawtab 

nokk-0 

if (icon(2) .ge.3)nokk=l 
if (nokk) 3, 3, 1 

1  do  2  i-1,1024 
iil (i) «0 

jjl (i) -0 

2  itgl (i) -0 

3  nrcnt-0 

10  if (nokk) 11,12, 11 

11  read (ni tape) nints, 1st  red,  iil,  jjl, itgl 

go  to  13 

12  read(nitape) nints, 1st red,  iil, jjl, itgl 

13  nrcnt-nrcnt+1 

if (nints . le. 0) gotol915 

if  (  nints . le . 0 . or . nints .gt . ninmax) goto8C 0 
do  91 6m«l, nints 
i-iil (m) 
j-j jl  (m) 
itag-itgl (m) 
if  (itag-1) 403,402,408 
408  valint (m) --prvint 
go  to  916 

402  valint (m) -prvint 
go  to  916 

403  valint (m) -0 . dO 
ityp-ntype (i) 
jtyp-ntype ( j) 
if (ityp. le . jtyp) goto404 
itypt-ityp 
itemp-i 
ityp-jtyp 

i-j 

jtyp-itypt 
j-itemp 

404  continue 

11- nr (ityp, 1) 

12- nr ( jtyp, 1) 
ml -nr (ityp, 2) 
m2-nr ( jtyp, 2) 
nl-nr (ityp, 3) 
n2-nr ( jtyp, 3) 
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mx-11+12+1 
my-ml+m2+l 
mz-nl+n2+l 
i3-nfirat <i) 
if-nlaat (i) 
ja-nfirat  < j) 
jf-nlaat  { j) 
do  635ii-ia,if 
a-eta (ii, 4) 
ax-eta (ii, 1) 
ay-eta (ii, 2) 
az-eta (ii, 3) 
do  1635jj-ja,jf 
b-eta(  j j,4) 
bx-eta< j  j , 1 ) 
by-eta ( j j , 2 ) 
bz-eta ( j j, 3) 
tl-a+b 
t-l.dO/tl 
pi- (a*ax+b*bx) *t 
p2- (a*ay+b*by) *t 
p3- (a*az+b*bz) *t 
abl-ax-bx 
ab2-ay-by 
ab3-az-bz 

di3tab-abl*abl+ab2*ab2+ab3*ab3 

phase-exp (-a*b*distab*t) 

aoo-4 .dO*pi*eta (ii, 5) *eta ( j j, 5) 

vaoo-t*phaae*0 . 5d0 

vlp-0 . OdO 

vnai-0 . d 0 

do  690n-l,noc 

vx-vlist (n, 1) 

vy-vliat (n, 2) 

vz-vliat (n, 3) 

pcx-pl-vx 

pcy-p2-vy 

pcz-p3-vz 

pcsq-pcx*pcx+pcy*pcy+pcz*pcz 

arg-tl*pcaq 

y-exp(-arg) 

f6-fmch(6,arg,y) 

arg-2 .dO*arg 

if  (y  .It.0.0d0)goto25 

f5* (arg*f 6+y) *xll 

f 4- (arg*f 5+y) *x9 

f 3- (arg*f 4+y) *x7 

f2- (arg*f 3+y) *x5 

fl- (arg*f2+y) *x3 

fO-  arg*fl+y 

go  to  29 

25  f 5-2 . OdO*ap5*xll 

f 4-4 . 0d0*ap4*xll*x9 
f 3-8 . 0d0*ap3*xll*x9*x7 
f2-16.0d0*ap2*xll*x9*x7*x5 
f 1-32 . OdO*apl*xll*x9*x7*x5*x3 
f 0-64 . 0d0*ap0*xll*x9*x7*x5*x3 
29  continue 
pax-pl-ax 
pbx-pl -bx 

call  gfunct (11, 12, pax, pbx, pcx, t, g,  1) 

pay-p2-ay 

pby-p2 -by 

call  gfunct (ml,m2,pay,pby,pcy, t,g, 2) 
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paz-p3-az 

pbz-p3-bz 

call  gfunct (nl,n2,paz,pbz,pcz,t,g, 3) 

rawint-0 .dO 

do  506ix-l,mx 

do  507jy-l,my 

do  508kz-l,mz 

mxyz-ix+ jy+kz-2 

508  rawint=rawint+g (ix, l)*g(jy,2)*g(kz,3)*f (mxyz) 

507  continue 
506  continue 

c  write  (60, 100)  i, j, ii, j j,n, rawint 

c  100  format  (2x, '  i-' ,  i3, 2x, '  j-' ,  i3,  2x, '  ii-' ,  i3,  2x, '  jj-' ,  i3,  2x, 
c  1  '  nn»' , i3, 2x, ' rawint-' , el6 . 8 ) 
xint-0 . OdO 
nc-lpskip (n) 
charge-vlist (n, 4) 
dumch-cha  rge 
if (nc) 690, 690, 600 
600  dumch  «0.0d0 


c 

c 

c 

c 


c 

c 

c 


if ( (distab+pcsq) . gt . 1 . 0d-06) goto602 

601  call  vaaa 

write(60,110)i,j,ii,jj, n, xint , soo, charge 

110  format (2x, '  i-' , i3, 2x, ' j-' ,  i3, 2x, ' ii*' , i3, 2x, '  j j-' , i3, 2x, 
1  ' nn«' , i3, 2x, ' xint*' , el6 . 8, 2x, ' vaaa' , /, '  soo-',fl5.6, 

1  '  charge-' , f 15. 6) 
vlp-vlp+xint 
go  to  690 

602  avx-ax-vx 
avy-ay-vy 
avz»az-vz 

avsq=avx*avx+avy*avy+avz*avz 

bvx»bx-vx 

bvy=by-vy 

bvz=bz-vz 

bvsq-bvx*bvx+bvy*bvy+bvz*bvz 
if(avsq)603, 603, 604 

603  bv=dsqrt (bvsq) 

call  vbaa (bvx, bvy ,bvz, bv,c,  jtyp, a, ityp) 
write (60, 111) i, j,ii,jj,n,xint 

111  format  <2x, ' i-' , i3, 2x, ' j=' , i3, 2x, ' ii”' , i3, 2x, ' j j-' , i3, 2x, 
1  ' nn*' ,13, 2x, 'xint»' ,el6. 8, 2x, ' vbaa-1 ' ) 


vlp-vlp+xint 
go  to  690 

6C4  if (bvsq) 605, 605, 606 

605  av«dsqrt (avsq) 

call  vbaa (avx, avy, avz, av, a,  ityp, b, jtyp) 
c  write (60, 112) i, j , ii, jj , n, xint 

c  112  format (2x, '  i-' , i3, 2x, ' j-' ,  i3,  2x, ' ii-' , i3, 2x, ' jj-' , i3, 2x, 
c  1  '  nn-' ,  i3,  2x, ' xint-' , el6 . 8, 2x, ' vbaa-2' ) 
vlp-vlp+xint 
go  to  690 

606  av-dsqrt (avsq) 
bv-dsqrt (bvsq) 
call  vbca 

c  write (60, 113) i, j, ii, jj, n, xint 

113  format (2x, ' i«' , i3, 2x, ' j-' , i3,  2x, ' ii-' , i3, 2x, ' j j-' , i3, 2x, 
c  1  '  nn-' , i3,  2x, ' xint-' , el6 . 8, 2x, ' vbca' ) 
vlp-vlp+xint 

690  vnai«vnai-rawint*dumch 
c  write (60, 1927) , vlp 

cl927  format(lx, '  sum  of  on  6  off  center  int.',fl3.6) 

1635  valint (m) -valint (m) + (vnai*vsoo+vlp) *soo 

635  continue  i  ,  i 
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prvint-valint (m) 

916  continue 

1915  if (nokk) 1916, 1917, 1916 

1916  write (notape) nints, 1st red, iil, jjl, itgl, valint 
go  to  1918 

1917  write (notape) nints, 1st red, iil, j jl, itgl, valint 

1918  if (1st red) 915, 10, 915 
915  continue 

c 

c  write  out  results  of  ddmx  test 
c 

write (60, 7114) ddtest 

7114  format  (lx,'  the  lowest  value  of  -ddmx  that  resulted  in  a',/,' 

1  change  of  the  integral  of  more  one  part  in  1.0e-12  is:',dl5.8) 
return 

800  write  (6, 992) nrent, nints 
stop 

992  format  (  /  3x,  43h**  tape  read  error  in  vints  ,  nrent  =  ,i5, 
x  llh  ,  nints  =,il0,4h  **  ) 

end 

subroutine  vaaa 

c  this  subroutine  evaluates  the  integrals  involving  gaussians 

c  which  are  centered  at  the  location  of  the  effective  potential, 

c  the  effective  potential  reduces  to  two  terms  [vcore  +  vl], 

c  this  is  due  to  the  orthonormality  of  the  angular  part  of  the 

c  wavefunctions .  notice  that  x**2,  y**2,  z**2  are  not  pure  spherical 

c  harmonics  thus  we  get  three  terms  [vcore  +  vs  +  vd]  for  these 
c  gaussians. 

c 

implicit  double  precision (a-h, o-z) 

common/bfcom/xaaa, ityp,  jtyp, zi, z j, kc, idum, zdum(13) , zval 
common/int2/nlp (200) , clp (200) , zip (200) , lstrl (20) , lstr2 (20) , 

1  lstr3 (20) , lstr4 (20)  ,  lstpl (20)  ,  lstp2 (20)  ,  lstp3 (20) ,lstp4 (20) , 

1  ldsrl (20) ,ldsr2 (20)  ,ldsr3 (20)  ,  ldspl (2C)  ,  ldsp2 (20) , ldsp3 (20) , 

1  usmx (20), dpmx (20), ddmx (20), xmx (20), lmax  (20) 
common /aaacom/zet a 

c  data  fourpi/12 . 56637060d0/  deleted 
data  pi/3. 1415926535897932384 6d0/ 
c 

xaaa-0 .  OdO 
xi j=zi+z j 

if ( jtyp.gt . 4) gotolOl 
if (ityp.ne. jtyp) return 
go  to  (1,2, 2, 2) , jtyp 
101  if (jtyp.gt. 7)goto3 
if (ityp.eq. l)goto4 
if (ityp.le.4) return 
if (ityp.ne. jtyp) goto5 
go  to  6 
c 

c  <s/vs/s> 
c 

1  lstrt=lstr4 (kc) 
lstop=lstp4 (kc) 

c  write (60, 777) kc, 1st rt 1,1st opl, zval 

do  11  k-lstrt, lstop 
zeta=xi j+zlp (k) 

11  xaaa=xaaa-zval*clp (k) *dsqrt (zip (k) / zeta) / (2 . 0d0*xi j ) 
c 

c  write (60, 780) xaaa 

c  780  format (lx, ' the  <vcore>  integral-' , f 15 . 6) 
buff-0. OdO 
lstrtl-ldsrl (kc) 
lstopl-ldspl (kc) 

m 
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do  10  k-lstrtl, latopl 
zeta»xi j+zlp (k) 
n-nlp (k) 

c  write (60, 778)n, zip (k) ,clp(k) , zi, zj, (fa  (n)  *clp  (k) ) 

buf f-buf f+fa (n) *clp  <k) 

10  xaaa«xaaa+fa (n) *clp (k) 
c  write (60, 2817) buf f 

c  2817  format (lx, '  <ylm>  =',dl5.8) 
return 
c 

c  <p/vp/p> 
c 

2  lstrt=lstr4 (kc) 
lstop-lstp4 (kc) 

do  13  k«latrt, lstop 
zeta=xi j+zlp (k) 

xaaa=xaaa-zval*clp (k) *dsqrt (zip (k) /pi) * (fa (2) +fa (0) /xi j) 

#  /xi  j 
13  continue 

c  write (60, 780) xaaa 

Iatrt2»ldsr2 (kc) 
lstop2-ldsp2  (kc) 
do  20  k=lstrt2, lstop2 
zeta=xi j+zlp (k) 
n-nlp (k) +2 

20  xaaa-xaaa+fa (n) *clp (k) 

xaaa=xaaa*0 . 3333333333333d0 
return 

c 

c  pure  <d/vd/d> 

c 

3  if (ityp.ne. jtyp) return 
lstrt=lstr4 (kc) 
lstop-lstp4 (kc) 

do  31  k=latrt, lstop 
zeta=zlp(k)+xi j 

31  xaaa=xaaa-zval*clp (k) *dsqrt (zip (k) /pi) * (fa (4) +2 . OdO* 

#  (fa (2) +fa (0) /xi j) /xi j) /xi j 

c  write (60, 780) xaaa 

buff-0. OdO 
Istrt3-ldsr3 (kc) 
lstop3«ldsp3 (kc) 
do  30  k-lstrt3, lstop3 
zeta*xi j+zlp (k) 
n-nlp (k) +4 

buf f-buf f+fa (n) *clp (k) 

30  xaaa-xaaa+fa (n) *clp (k) 
xaaa-xaaa/15 . OdO 
buf f-buf f/15. OdO 
c  write (60, 1529) buf f 

cl529  formatdx,'  pure  d  <d/vd/d>/15  =',dl5.8) 
return 
c 

c  <s/vlm/ri*ri> 

c 

4  latrt»lstr4 (kc) 
lstop-latp4 (kc) 

do  41  k-lstrt, lstop 
zeta»xi j+zlp (k) 

41  xaaa-xaaa-zval*clp (k) * (3 . 0d0*xi j+2 . OdO *  zip (k) ) * 

#  daqrt (zip (k) /zeta) / (4 . 0d0*xi j*xi j*zeta) 

c  write (60, 781 ) xaaa 

c  781  formatdx,'  <s/vcore/ri*ri>-  ...  xaaa-' ,dl5. 8) 
buff-0. OdO 
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lstrtl-ldsrl (kc) 
lstopl-ldspl (kc) 
do  40  k-lstrtl, lstopl 
zeta-xi j+zlp (k) 
n-nlp (k) +2 

buf f-buf f+fa (n) *clp (k) 

40  xaaa-xaaa+fa (n) *clp <k) 

xaaa-xaaa*0 . 3 33333333 33 33d0 
buff-buff/? . OdO 
c  write (60, 1427) buff 

c  1427  format(lx,'  <s/vs/ri*ri>/3  ,dl5.8) 
return 
c 

c  <ri*ri/vlm/r j*r j>  i  .ne.  j 

c 

5  xcore-O.OdO 
lstrt-lstr4 (kc) 
lstop-lstp4 (kc) 

do  51  k»lstrt, lstop 
zeta«zlp (k) +xi j 

51  xcore=xcore-zval*clp (k) *dsqrt (zip (k) /pi) * (fa (4) +2 . OdO* 

#  (fa  (2) +fa  (0) /xi  j) /xi  j) /xi  j 
xcore*xcore/15. OdO 

c  write (60, 780) xcore 

lstrtl-ldsrl (kc) 
lstopl-ldspl (kc) 

I3trt3»ldsr3 (kc) 
lstop3-ldsp3 (kc) 
buf f-0 . OdO 

do  50  k=*lstrtl,  l3topl 
zeta**xij+zlp  (k) 
n-nlp (k) +4 

buf f-buf f+fa (n) *clp (k) 

50  xaaa-xaaa+fa (n) *clp (k) 
c  write (60, 7531) buf f 

c  7531  formatdx,'  <ri*ri/vs/r j*r j>  i  .ne.  j=',dl5.8) 
buff-0 . OdO 
xddd-0 . OdO 

do  55  k-lstrt3, lstop3 
zeta-xi j+zlp (k) 
n-nlp (k) +4 

buf f-buf f+fa (n) *clp (k) 

55  xddd-xddd+fa (n) *clp (k) 
c  write (60, 3618) buff 

c3618  formatdx,'  <ri*ri/vd/r j*r j>  i  .ne.  j«',dl5.8) 
xaaa- (xaaa-0 . 4d0*xddd) *0.11111 lllllllldO 
xaaa-xaaa+xcore 
return 
c 

c  <ri*ri/vlm/ri*ri> 

c 

6  xcore-O.OdO 
lstrt-lstr4 (kc) 
lstop— 1 stp4 (kc) 

do  61  k-lstrt, lstop 
zeta-xi j+zlp (k) 

61  xcore-xcore-zval*clp (k) *dsqrt (zip (k) /pi) * (fa (4) +2 . OdO* 

#  (fa  (2) +fa  (0) /xi  j) /xi  j) /xi  j 
xcore-xcore/5 . OdO 

c  write (60, 780) xcore 

lstrtl-ldsrl (kc) 
lstopl-ldspl (kc) 

Istrt3-ldsr3 (kc) 
lstop3-ldsp3 (kc) 
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buff-0. OdO 

do  60  k-lstrtl, lstopl 
zeta-xi j+zlp (k) 
n-nlp (k) +4 

buf f-buf f+fa (n) *clp (k) 

60  xaaa-xaaa+fa (n) *clp (k) 
c  write (60, 2615) buf f 

c2615  format (lx,'  <ri*ri/vlm/ri*ri>«' , dl5 . 8) 
buff-0. OdO 
xddd-0 . OdO 

do  65  k-lstrt3, lstop3 
zeta-xi j+zlp (k) 
n»nlp (k) +4 

buf f-buf f+fa (n) *clp (k) 

65  xddd-xddd+fa (n) *clp (k) 
c  write (60, 7451) buf f 

c7451  format  (lx,'  <ri*ri/vlm/ri*ri>=' ,dl5. 8) 
xaaa- (xaaa+0 . 8d0*xddd) ‘O.llllllllllllldO 
xaaa-xaaa+xcore 
return 
end 

subroutine  vbaa (bax, bay, baz, ba , zetal , jtyp, zeta2, ityp) 
c 

implicit  double  precision (a-h, o-z) 

common/bfcom/xbaa, idum (2 ) , dum(2 ) , kc, jdum,  gdum(13) , zval 
common /int 2 /nip (200) ,clp(200) , zip (200) , lstrl (20) ,lstr2 (20) , 

1  lstr3 (20) , lstr4 (20) , lstpl (20) ,lstp2 (20)  ,  lstp3(20)  ,lstp4 (20) , 
1  ldarl (20)  ,ldsr2 (20) ,ldsr3 (20) , ldspl (20) ,ldsp2 (20) , ldsp3 (20) , 
1  dsmx (20) ,dpmx (20) , ddmx (20) ,xmax (20) , lmax (20) 
common/erfp/b, xi j 

c  data  fourpi/12 . 56637060d0/  deleted 

data  pi/ 3 . 14159265358  97 932 384 6d0/ 
xbaa-0 . OdO 
xi j-zetal+zeta2 
b=ba*zetal 
a-b*2 . OdO 
ail-1 . OdO/a 
d=b*ba 

c  write (60,  7251) bax, bay, baz, ba 

c7251  format (lx, '  vbaa=>  bax-' , dl5 . 8 , / , '  bay=',dl5.8, 
c  #  /,'  baz-' ,dl5. 8, '  ba=',dl5.8) 
dx-bax/ba 
dy»bay/ba 
dz-baz/ba 
delxk-0 . OdO 
delyk-0 . OdO 
delzk-0 . OdO 
delxl-0 . OdO 
delyl-0 . OdO 
delzl=0.0d0 
c 

value-0 . OdO 
c 

go 
go 

501  go 
go 

502  go 
go 

50  3  go 
go 

504  go 
go 


iv>~ 


to  (501, 502, 503, 504,505, 506, 507, 508, 509, 510) , ityp 
to  1 

to  (10,20,40, 80, 151, 153, 156,152, 154,155) , jtyp 
to  1 

to  (21,30, 50, 90, 171, 173, 176,172, 174,175) , jtyp 
to  1 

to  (41, 50,70, 110, 181, 183,186, 182, 184,185) , jtyp 
to  1 

to  (81,90,110,150,191,193,196,192,194,195) , jtyp 
to  1 


c 
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c  sb - sa 

10  lstrtl-lstr4 (kc) 
lstopl»lstp4 (kc) 

c 

do  14  k-lstrtl, lstopl 

zeta-xi j+zlp (k) 

exa-exp (-d* {1 . OdO-zetal/xi j) ) 

ck— zval*clp  (k)  *exa 

x-zetal*ba*dsqrt (zip (k) / (zeta*xi j) ) 

call  vvmval (2 , 2,x, vml , vmO) 

14  value-value+ck*vmO 
c 

c  write (60, 2838) value 

c2838  format (lx, '  <s/core/s>vbaa=' , dl5 . 8) 
lstrtl-ldarl (kc) 
lstopl-ldspl (kc) 
do  11  k-lstrtl, l3topl 
zeta-xi j+zlp (k) 
n-nlp (k) 

exa-exp (-d* (1 . OdO-zetal/zetai) 

srzi»l . OdO/dsqrt (zeta) 

ck=clp (k) *exa* (srzi**n) *0. 5d0*ail 

x«b*srzi 

call  vvmval  (0,  n, x,  vm,  v) 

11  value=value+ck*vm 

c  write (60, 2839) value 

c  2839  format (lx,'  value=' , f 15 . 9) 
go  to  290 

c  xb - sa 

20  c00=-bax 
cll=bax/ba 

22  if (cOO .eq. 0 . OdO) return 
c 

lstrtl=-lstr4  (kc) 
lstopl* Is tp4 (kc) 

c 

bvm0*0 . OdO 
bvml*0 . OdO 

ao  15  k=lstrtl, lstopl 

zeta=xi j+zlp (k) 

exa=exp (-d* (1 . OdO-zetal /xi j) ) 

ck*-zval*clp (k) *exa 

x*zetal*ba*dsqrt (zlp(k)/ (zeta*xij)) 

call  vvmval (2,2, x,vml,vm0) 

bvm0*bvm0+ck*vm0 

bvml=bvml+ck*vm.' 

15  value=value+ck* (c00*vm0+cll*vml ) 

c  write (60, 7739) value,  bvmO, bvml 

c7739  format (lx,'  vbaa  <x/core/sa>=  ',dl5.8,/, 
c  #  '  mO-  ' , dl5 . 8 , '  r *ml  =',dl5.8) 

lstrtl*ldsrl (kc) 
lstopl=ldspl (kc) 
do  23  k*l3trtl , lstopl 
zeta*xi j+zlp (k) 
n*nlp (k) 
nl*n+l 

exa-exp (-d* (1 . OdO-zetal /zeta) ) 

srzi-l . OdO/dsqrt (zeta) 

ck-clp (k) *exa* (srzi**n)*0. 5d0*ail 

x»b*srzi 

call  vvmval (l,n,x,vm,v) 

23  value-value+ck* (c00*vm+cll*srzi*v) 
go  to  290 

c  sb - xa 
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21  cll-bax/ba 

24  if (ell .eq. 0 . OdO) return 
c 

lstrtl-lstr4 (kc) 
lstopl»lstp4 (kc) 
c 

do  16  k~lstrtl, lstopl 
zeta-xi j+zlp(k) 
exa-exp(-d* (1 . OdO-zetal/xi j) ) 
ck— zval*clp  (k)  *exa 

x=zetal*ba*dsqrt (zip (k) / (zeta*xi j) ) 
call  vvmval (2,2, x, vml, vmO) 

16  value=value+ck*vml 
c 

c  write (60, 2271) value 

c2271  format (lx,'  <s/core/x>=  ',dl5.8) 
c  value=value*cll 

Istrt2“ldsr2 (kc) 
l3top2”ldsp2 (kc) 
do  25  k=lstrt2, lstop2 
zeta*xi j+zlp (k) 
n»nlp (k) 
nl-n+1 

exa=exp (-d* (1 • OdO-zetal/ zeta) ) 

srzi*l . OdO/dsqrt (zeta) 

ck*clp (k) *exa* (srzi**n) *0 . 5d0*ail 

x=*b*srzi 

call  vvmval (l,n,x,vm,v) 

25  value=value+ck*v*srzi 
value=cll*value 

go  to  290 
c  xb - xa 

30  bij=bax*bax 

C20*0 . 333 3333333 3 33d0 
c00*0 . OdO 

31  if (bi j .eq. 0. OdO . and. c20 .eq. 0 . OdO) return 
cll»-bi j/ba 

c22--cll/ba-c20 
c20-c20+c22 
cll«cll-3.0d0*c22/a 
c00s=0 . OdO 
c 

l3t  rtl*lstr4 (kc) 
l3topl*l3tp4 (kc) 
c 

bvm0**0 .  OdO 
bvml*0 .  OdO 
bvm2»C . OdO 
bvm3*0 . OdO 

do  17  k»lstrtl, lstopl 
zeta»xi j+zlp(k) 
exa«exp(-d* (l.OdO-zetal/xij) ) 
ck— zval*clp  (k)  *exa 

x-zetal*ba*dsqrt (zlp(k) / (zeta*xi j) ) 

call  vvmval (2, 2, x, vml, vmO) 

bvmO“bvmO+vmO*ck 

bvml -bvml +ck*vml 

cllvml«cll*vml 

call  vvmval (2,  4,  x, vml, vmO) 

bvm2 -bvm2 +c  k  *  vmO 

bvm3“bvm3+ck*vml 

17  value-value+ck* (cllvml+c20*vm0) 


c 

c 


write (60, 1719) value, bvmO, bvml, bvm2,bvm3 


/ 
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cl719  format (lx,'  vbaa  <p/core/p>«  ',dl5.8,/,'  mO-' , 
c  #  dl5 . 8, '  r*ml*' , dl5 • 8,  /, '  r*r*m0-' , dl5 . 8, 

c  #  '  r*r*r*ml-' ,dl5.8) 

Istrt2«ldsr2 (kc) 
lstop2«ldsp2 (kc) 

936  do  32  k«lstrt2,lstop2 
zeta»xi j+zlp (k) 
n-nlp (k) 
nl-n+1 

exa-exp (-d* (1 . OdO-zetal/zeta) ) 

srzi-1 . OdO/dsqrt (zeta) 

ck-clp (k) *exa* (srzi**n) *0 . 5d0*ail 

x«*b*srzi 

call  vvmval (l,n,x,vm,v) 

32  value»value+ ( (c00+c20*nl*0 . 5d0/zeta) *vm+ (cll+c20*x*srzi) * 
#  srzi*v  ) *ck 
if(c00s.eq.0. OdO) goto290 
36  if (lmax (kc) .eq. 0) goto290 
lstrt=ldsrl (kc) 
latop«ld3pl (kc) 
do  12  k**lstrt,  lstop 
zeta=xi j+zlp (k) 
n»nlp (k) +2 

exa=exp (-d* (1 . OdO-zetal/zeta) ) 
srzi=l . OdO/dsqrt (zeta) 

ck»clp (k) *exa* (srzi**n) *ail*0 . 1666666 6 66666d0 
x»b*srzi 

call  vvmval (0, n, x, vm, v) 

12  value=value+ck*vm 

if  (lmax (kc) . It . 3) goto290 
lstrt=ldsr3 (kc) 
lstop=ldsp3 (kc) 
do  13  k»lstrt, lstop 
zeta-xi j+zlp (k) 
n*nlp (k) +2 

exa=exp (-d* (1 . OdO-zetal/zeta) ) 
srzi=l . OdO/dsqrt (zeta) 
x~b*srzi 

ck«clp (k) *exa* (srzi** (n-1) ) *0 . 5d0*ail 
c00= (d22+d20) * (n-1 ) *0 . 5d0*srzi 
cll“(d22+d20) * (a/ (2. OdO* zeta) -3. OdO /a) 
call  vvmval (1 , n, x, vm, v) 

13  value=value+ck* (c00*vm+cll*v) 
go  to  290 

c  yb - sa 

40  c00«-bay 
cll=bay/ba 
go  to  22 

c  sb - ya 

41  cll-bay/ba 
go  to  24 

c  yb - xa  or  xb ya 

50  bij»bax*bay 
c20«0.0d0 
c00-0. OdO 
go  to  31 

c  yb - ya 

70  bij«bay*bay 

c20-0  3333 3333 33333d0 
c00-0. OdO 
go  to  31 

c  zb - sa 

80  c00»-baz 
cll*baz/ba 


c  sb 
41 

c  yb 
50 


c  yb 
70 


c  zb 
80 
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go  to  22 

c  sb - za 

81  cll-baz/ba 
go  to  24 

c  xb - za  or  zb - xa 

90  bij«bax*baz 
c20-0.0d0 
cOO-O. OdO 
go  to  31 

c  yb - za  or  zb - ya 

110  bij«bay*baz 
c20-0.0d0 
c00**0 . OdO 
go  to  31 
c  zb - za 

150  bij»baz*baz 
c20»0.3333333333333d0 
c00*0 . OdO 

go  to  31 
c  sa - xxb 

151  c00»bax*bax 

c20«0 . 3333333333333d0 
go  to  34 
c  s  a - xyb 

152  c00«bax*bay 
c20-0.0d0 
go  to  34 

c  sa - yyb 

153  c00-bay*bay 

c20=0 . 33333333333 33d0 
go  to  34 
c  sa - xzb 

154  c00=bax*baz 
c20-0.0d0 
go  to  34 

c  sa - yzb 

155  c00«bay*baz 
c20«0.0d0 
go  to  34 

c  sa - zzb 

156  c00«baz*baz 
c20-0.3333333333333d0 

c 

34  ell— 2.0d0*c00/ba 

if (cOO . eq. 0 . OdO . and. c20 . eq. 0 . OdO) return 
c22«c00/ (ba*ba) -c20 
c20-c20+c22 
cll-cll-3.0d0*c22/a 
c00s-0 . OdO 
c 

lstrt*lstr4 (kc) 
lstop**lstp4  (kc) 
c 

bvmO-O . OdO 

bvml-0 . OdO 

bvm2«0 . OdO 

bvm3-0 . OdO 

do  341k»lstrt, lstop 

zeta-xi j+zlp(k) 

exa-exp (-d* (1 . OdO-zetal/xi j) ) 

ck—zval*clp  (k)  *exa 

x-zetal*ba*dsqrt (zip (k) / (zeta*xi j) ) 

call  vvntval  (2, 2,x,  vml,  vmO) 

bvmO  “bvmO + c  k  *  vmO 

U? 
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bvml-bvml+ck*vml 

c00vm0-c00*vm0 

cl  lvml-cl  1  *vml 

call  wmval  (2,  4,x,  vml,  vmO) 

bvm2 -bvm2 +ck * vmO 

bvm3*bvm3+ck*vml 

341  value-value+ck* (c00vm0+cllvml+c20*vm0) 
c  write (60, 1847)bvm0,bvml,bvm2,bvm3 

c  1847  format (lx, '  vmO-' ,dl5. 8, 2x, '  r*vml-' , dl5. 8, /, 
c  #  '  r*r*vm0-' ,  dl5 . 8, 2x, '  r*r*r*vml»' ,dl5. 

Istrt2-ldsrl (kc) 
lstop2-ldspl (kc) 
go  to  936 
c 

c  xxa - sb 

161  bij”bax*bax 

c20»0 . 333333333333 3d0 
k22-0.5d0 

k20»-0 . 166666666 6 66666d0 
go  to  35 
c  xya - sb 

162  bij“bax*bay 
c20-0.0d0 
go  to  35 

c  yya - sb 

163  bij«bay*bay 

c20*0 . 33333333333 33d0 
k22-0.5d0 

k20”-0 . 16666666 6 66666d0 
go  to  35 
c  xza - sb 

164  bij«bax*baz 
c20«0.0d0 
go  to  35 

c  yza - sb 

165  bij=>bay*baz 
c20»0.0d0 
go  to  35 

c  zza - sb 

166  bij*baz*baz 

c20»0 . 33333333333 33d0 
k22-0.0d0 

k20-0.3333333333333d0 

c 

35  c00-0. OdO 

if  (bi j . eq. 0 , OdO . and. c20 . eq. 0 . OdO) return 
c22-bij/(ba*ba)-c20 
cOOs-3 . 0d0*c20 
c20-c20+c22 
ell— 3.0d0*c22/a 
Istrt2-lstr4 (kc) 
lstop2-lstp4 (kc) 
c 

bvmO-O . OdO 
bvml-0 . OdO 
bvm2-0.0d0 
bvm3“0 . OdO 

do  351k-lstrt2, lstop2 

zeta-xi j+zlp(k) 

exa-exp (-d* (1 . OdO-zetal/xi j) ) 

ck--zval*clp (k) *exa 

x-zetal*ba*dsqrt (zlp(k) / (zeta*xi j) ) 

call  vvmval  (2, 2,  x,  vml,  vniO) 

bvm0«bvm0+ck*vm0 
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bvml-bvml  +ck*vml 

c00vm0-c00*vm0 

cllvml-cll*vml 

call  wmval  (2, 4,x,  vml,  vmO) 

bvm2 -bvm2 + c  k  *  vmO 

bvm3-bvm3+ck*vml 

351  value-value+ck* (c00vm0+cllvml+c20*vm0) 
c  write{60,l847)bvm0,bvml,bvm2/bvin3 

d22- (dx*dx-dy*dy) *k22 
d20«(3.0d0*dz*dz-1.0d0) *k20 
go  to  36 
c 

c  xa - xxb 

171  bi jk«bax*bax*bax 
c31-0 . 6d0*bax/ba 

c20— 0 . 6666666666  66  6d0  *bax 
go  to  131 
c  xa - xyb 

172  bi  jk=*bax*bax*bay 
c31-0 . 2d0*bay/ba 

c20— 0.3333333333333d0*bay 
go  to  131 
c  xa - yyb 

173  bi jk-bax*bay*bay 
c31-0 . 2d0*bax/ba 
c20«0 . OdO 

go  to  131 
c  xa - xzb 

174  bi jk«bax*bax*baz 
c31**0 . 2d0*baz/ba 

c20— 0 . 333333  333  3333d0*baz 
go  to  131 
c  xa - yzb 

175  bi jk-bax*bay*baz 
cSl^O . OdO 
c20-0.0d0 

go  to  131 
c  xa - zzb 

176  bi jk-bax*baz*baz 
c31«0.2d0*bax/ba 
c20-0.0d0 

go  to  131 
c  ya - xxb 

181  bi jk-bay*bax*bax 
c31-0 . 2d0*bay/ba 
c20-0.0d0 

go  to  131 
c  ya - xyb 

182  bi jk-bay*bax*bay 
c31-0 . 2d0*bax/ba 

c20«-0 . 3333333333 333d0*bax 
go  to  131 
c  ya - yyb 

183  bi jk«bay*bay*bay 
c31-0. 6d0*bay/ba 

c20— 0.6666666666666d0*bay 
go  to  131 
c  ya - xzb 

184  bi jk-bay*bax*baz 
c31-0.0d0 
c20-0.0d0 

go  to  131 
c  ya - yzb 

185  bi jk»bay*bay*baz 
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c31-0 . 2d0*baz/ba 

c20— 0 . 3333333333333d0*baz 

go  to  131 

c  ya - zzb 

186  bi jk«bay*baz*baz 
c31-0 . 2d0*bay/ba 
c20-0.0d0 
go  to  131 
c  za - xxb 

191  bi jk-baz*bax*bax 
c31-0.2d0*baz/ba 
c20-0.0d0 

go  to  131 
c  za - xyb 

192  bi jk«baz*bax*bay 
c31**0 .  OdO 
c20-0.0d0 

go  to  131 
c  za - yyb 

193  bi jk«baz*bay*bay 
c31«0.2d0*baz/ba 
c20-0.0d0 

go  to  131 
c  za - xzb 

194  bi jk-baz*bax*baz 
c31«0 . 2d0*bax/ba 

c20— 0.3333333333333d0*bax 
go  to  131 
c  za - yzb 

195  bi jk-baz*bay*baz 
c31-0 . 2d0*bay/ba 

c20"-0 . 33333333333 3 3d0*bay 
go  to  131 
c  za - zzb 

196  bi jk«baz*baz*baz 
c31«0.6d0*baz/ba 

c20«-0 . 66666666 66666d0*baz 
go  to  131 
c 

c  xxa - xb 

201  bi jk-bax*bax*bax 
c31»0 . 6d0*bax/ba 

c20*-0 . 33333333333 33d0*bax 

bck-bax 

dk-dx 

delxk-l . OdO 
k22-0.5d0 
k20»-l . OdO/6. OdO 
go  to  133 
c  xxa - yb 

202  bi jk-bax*bax*bay 
c31-0.2d0*bay/ba 

c20“-0 . 333333333 33 33d0 ‘bay 
bck-bay 
dk-dy 
k22-0.5d0 
k20— 1.  OdO/6.  OdO 
go  to  133 
c  xxa zb 

203  bi jk«*bax*bax*baz 
c31-0 . 2d0*baz/ba 

c20— 0.3333333333333d0*baz 

bck-baz 

dk-dz 
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k22-0.5d0 
k20*-l .  OdO/6 .  OdO 
go  to  133 
c  xya - xb 

204  bi jk«bax*bay*bax 
c31-0.2d0*bay/ba 
c20-0 . OdO 

go  to  133 
c  xya - yb 

205  bi jk-bax*bay*bay 
c31-0 . 2d0*bax/ba 
c20-0.0d0 

go  to  133 
c  xya - zb 

206  bi jk»bax*bay*baz 
c31-0.0d0 
c20«0.0d0 

go  to  133 
c  yya - xb 

207  bi jk-bay*bay*bax 
c31-0 . 2d0*bax/ba 

c20— 0.3333333333333d0*bax 
bck-bax 
dk-dx 
k22-0.5d0 
k20— 1.  OdO/ 6.  OdO 
go  to  133 
c  yya yb 

208  bi jk-bay*bay*bay 
c31**0 . 6d0*bay/ba 
bck-bay 

dk=dy 

delyk»l . OdO 
k22-0.5d0 
k20— 1. 0d0/6.  OdO 
go  to  133 
c  yya - zb 

209  bi jk~bay*bay*baz 
c31-0 . 2d0*baz/ba 

c20— 0.3333333333333d0*baz 
bck*baz 
dk«dz 
k22-0.5d0 
k20— 1. 0d0/6.  OdO 
go  to  133 
c  xza - xb 

210  bi jk-bax*baz*bax 
c31-0.2d0*baz/ba 
c20-0 . OdO 

go  to  133 
c  xza - yb 

211  bi jk»bax*baz*bay 
c31-0.0d0 
c20-0.0d0 

go  to  133 
c  xza - zb 

212  bi jk-bax*baz*baz 
c31«0.2d0*bax/ba 
c20-0.0d0 

go  to  133 
c  yza - xb 

213  bi jk-bay*baz*bax 
c31-0.0d0 
c20-0.0d0 

n) 
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go  to  133 
c  yza - yb 

214  bi jk-bay*baz*bay 
c31-0 . 2d0*baz/ba 
c20-0.0d0 

go  to  133 
c  yza - zb 

215  bi jk-bay*baz*baz 
c31-0 . 2d0*bay/ba 
c20-0.0d0 

go  to  133 
c  zza - xb 

216  bi jk«baz*baz*bax 
c31-0 . 2d0*bax/ba 

c20— 0 . 333333333 333 3d0*bax 
bck-bax 
dk-dx 
k22-0.0d0 
k20“l . OdO/3 . OdO 
go  to  133 
c  zza - yb 

217  bi jk«baz*baz*bay 
c31-0 . 2d0*bay/ba 

c20— 0.3333333333333d0*bay 
bck-bay 
dk-dy 
k22-0.0d0 
k20-l. OdO/3. OdO 
go  to  133 
c  zza - zb 

218  bi jk-baz*baz*baz 
c31»0 . 6d0*baz/ba 

c20— 0.3333333333333d0*baz 

bck-baz 

dk»dz 

delzk-l.OdO 
k22-0.0d0 
k20-l. OdO/3. OdO 
go  to  133 
c 

131  lstrt*ldsr2 (kc) 
lstop«ldsp2 (kc) 
Istrtl«l3tr4 (kc) 
l3topl*lstp4 (kc) 
c00«0 . OdO 
cll*bi jk/ba 
c22t-cll/ba 
c22— (2.0d0*c22t+c20) 
go  to  134 

133  Istrtl-l3tr4 (kc) 
lstopl-l3tp4 (kc) 
lstrt-lstop 
c00-c20 
cll-O.OdO 
c22t-bijk/ (ba*ba) 
c22— (c22t+c20) 

134  c33-c22t/ba-c31 
c31“c31+c33 
c22-c22-5.0d0*c33*ail 
c20-c20+c22 
cll-cll-3.0d0*c22*ail 


17  V 


c 


do  1341k-lstrtl, lstopl 
zeta-xi j+zlp(k) 
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exa-exp(-d* (1 . OdO-zetal/xi j) ) 
ck— zval*clp(k)  *exa 
x-zetal*ba*dsqrt (zlp(k) / (zeta*xi j) ) 
call  wmval(2,2,x,vrnl,vm0) 
cllvml-cll*vml 
call  wmval(2,4,x,vml,vm0) 

1341  value-value+ck* (c20*vm0+cllvml+c31*vml) 
c 

if(  lstrt.eq.lstop)gotol321 

do  132k-lstrt, lstop 

zeta-xi j+zlp (k) 

n-nlp(k) 

nl-n+1 

exa»exp(-d* (1 . OdO-zetal/zeta) ) 
srzi-1 . OdO/dsqrt (zeta) 
ck-clp(k) *exa* (arzi**n) *0 . 5d0*ail 
x»b*srzi 

call  wmval  (1,  n,  x,  vm,  v) 

c31z-c31/zeta 

c20z-c20*srzi 

cllz- (cll+c20z*x+c31z* (x*x+n*0 . 5d0) ) *srzi 
cOOz-  (c20z+c3lz*x) *nl*0 . 5d0*srzi 
132  value-value+ (c00z*vm+cllz*v) *ck 
go  to  290 

1321  if (lmax (kc) .eq. 0) goto290 
cll--c00/ba 
lstrt-ldsrl (kc) 
lstop-ldspl (kc) 
do  123k»lstrt, lstop 
zeta-xi j+zlp (k) 
n«nlp(k)+2 
nl-n+1 

exa«exp(-d* (1 . OdO-zetal/zeta) ) 
srzi-1 .OdO/dsqrt (zeta) 
ck-clp(k) *exa* (srzi**n) *0 . 5d0*ail 
x-b*srzi 

call  wmval (l,n,x,vm, v) 

123  value-value+ck* (c00*vm+cll*srzi*v) 
if  (lmax(kc) . It . 3) goto290 
lstrt-ldsr3 (kc) 
lstop-ldsp3 (kc) 
do  125k-lstrt, lstop 
zeta-xi j+zlp (k) 
n-nlp(k) 
nl-n+1 

exa-exp (-d* (1 . OdO-zetal/zeta) ) 

srzi-1 . OdO/dsqrt (zeta) 

ck-clp (k) *exa* (srzi**nl) *0 . 5d0*ail 

x-b*srzi 

d00»k22* (bck* (dy*dy-dx*dx) +ail* (5 . 0d0*dk* (dy*dy-dx*dx) + 

#  2. OdO* (dx*delxk-dy*delyk) ) ) 

dmll— k22* (3. OdO/a) * (bck* (dy*dy-dx*dx) tail* (5. 0d0*dk* 

#  (dy*dy-dx*dx) +2 . OdO* (dx*delxk-dy*delyk) ) ) 
dll-k22*dk* (dx*dx-dy*dy) 

d00-d00+k20* (bck* (1 . 0d0-3 . 0d0*dz*dz) -ail*3.0d0* (5.0d0*dk 

#  *dz*dz-2.0d0*dz*delzk-dk) ) 
dmll-dmll-k20*3.0d0*ail* (bck* (1 . 0d0-3 . 0d0*dz*dz) -ail*3 . OdO* 

#  (5.0d0*dk*dz*dz-2.0d0*dz*delzk-dk) ) 
dll-dll+k20*dk* (3 . 0d0*dz*dz-l . OdO) 
c00-nl*0. 5d0* (d00+dll*arzi) /zeta 

ell-  d00*a*0. 5d0/zeta+dmll+ 

#  dll*  (a*a*0.25d0/zeta+n/2 . OdO) /zeta 
call  wmval  (l,n,x,vm,v) 

125  value-value+ck* (c00*vm+cll*v) 


lopas . sub 


rri  Apr  S  11:22:53  1991 


go  to  290 

505  go  to  (161,201,202,203) , jtyp 
ai-bax 

a j-bax 

ia-1 

ja-1 

deli j-1 . OdO 
k22-0.50d0 
k20— 1.0d0/6.0d0 
delxi-1 . OdO 
delx  j-1 .  OdO 
go  to  511 

506  go  to  (163,207,208,209) , jtyp 
ai«bay 

a j-bay 

ia-2 

ja-2 

deli j-1 . OdO 
k22«0.50d0 
k20— 1.0d0/6.0d0 
delyi-l.OdO 
dely j-1 . OdO 
go  to  511 

507  go  to  (166,216,217,218) , jtyp 
ai-baz 

a j-baz 

ia-3 

ja-3 

deli j“l . OdO 
k22-0.0d0 
k20«l . OdO/3 . OdO 
delzi»l . OdO 
delz j»l . OdO 
go  to  511 

508  go  to  (162,204,205,206) , jtyp 
ai=bax 

a j-bay 

ia-1 

ja-2 

deli j-0 . OdO 
go  to  511 

509  go  to  (164,210,211,212) , jtyp 
ai-bax 

a j-baz 

ia-1 

ja-3 

deli j-0 . OdO 
go  to  511 

510  go  to  (165,213,214,215) , jtyp 
ai-bay 

a j-baz 

ia-2 

ja-3 

deli j-0. OdO 
go  to  511 

511  j jtyp- jtyp-4 
dxk-0 . OdO 
dxl-O.OdO 
dyk-0 . OdO 
dyl-0 . OdO 
dzk-0 . OdO 
dzl-0 . OdO 

go  to  (512,513,514,515,516,517) , j jtyp 

512  ak-bax 
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al-bax 

ka-1 

la-1 

dxk-1 . OdO 
dxl-1 . OdO 
delkl-1 . OdO 
go  to  231 

513  ak»bay 
al-bay 
ka-2 
la-2 

dyk-0 . OdO 
dyl-0. OdO 
delkl-1 . OdO 
go  to  231 

514  ak-baz 
al-baz 
ka-3 
la-3 

dzk-1 . OdO 
dzl-l.OdO 
delkl-1 . OdO 
go  to  231 

515  ak-bax 
al-bay 
ka-1 
la-2 

dxk-1 . OdO 
dyl-1 . OdO 
delkl-0 . OdO 
go  to  231 

516  ak-bax 
al-baz 
ka-1 
la-3 

dxk-1 . OdO 
dzl-l.OdO 
delkl-0. OdO 
go  to  231 

517  ak-bay 
al-baz 
ka-2 
la-3 

dyk-1 . OdO 
dzl-l.OdO 
delkl-0. OdO 
go  to  23x 

231  delik-0 . OdO 
delil-0. OdO 
del jk-O.OdO 
del jl-0. OdO 

if (ia.eq. ka) delik-1 . OdO 

if (ia.eq. la) delil-1 . OdO 

if ( ja.eq.ka)del jk-l.OdO 

if ( ja.eq.la)del jl-l.OdO 

ai j-ai*a j 

akl-ak*al 

ai jdkl-ai j*delkl 

akldi j-akl*deli j 

ai jkl-ai j*akl 

bai-1 . OdO/ba 

bai2-bai*bai 

aad-ai jdkl+akldi j+ai* (ak*del jl+al*del jk)+a j* (ak*delil+al*delik) 
dels-deli j*delkl+delik*del jl+delil*del jk 

177 
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c20-akldij*0.3333333333333d0 

c22t-aijkl*bai2 

c22*c22t-c20 

c31*- (aad-ai jdkl+akldi  j) *bai*0. 2d0 

c33—  (2 . 0d0*c22t*bai+c31 ) 

c40-dela/15.0d0 

c42t«*aad*bai2/7 .  OdO 

c42-c42t-del3/10 . 5d0 

c44»c22t*bai2-c42t+dela/35. OdO 

c42mc42+c44 

c33*c33-7 . OdO*c44*ail 

c40**c40+c42 

c31-c31+c33-3. OdO*c42*ail 

c22« c22-5. 0d0*c33*ail 

c20«c20+c22 

cl l*  -3. 0d0*c22*ail 

lstrt*latr4 (kc) 

lstop»l3tp4 (kc) 

bvmO-O . OdO 

bvml-0 . OdO 

do  2321k«lstrt, lstop 

zeta-xi j+zlp(k) 

exa=*exp  (-d*  (1 .  OdO-zetal/xi  j)  ) 

ck—zval*clp  (k)  *exa 

x=zetal*ba*dsqrt (zip (k) / (zeta*xi j) ) 

call  vvmval (2, 2,x, vml, vmO) 

c  1 1  vml  «c  1 1  *  vml 

call  vvmval (2, 4,x,vml,vm0) 

c20vm0-c20*vm0 

c31vml-c3l*vml 

call  vvmval  (2,  6,  x,  vml,  vmO) 

2321  value*value-tck* (c20vm0+cllvml+c31*vml+c40*vm0) 
c 

c  do  232  k-lstrt, lstop 

c  zeta*xi j+zlp(k) 

c  n=nlp(k) 

c  nl»n+l 

c  exa*»exp(-d* (1 . OdO-zetal/zeta) ) 

c  srzi»l . OdO/dsqrt (zeta) 

c  ck*clp (k) *exa* (srzi**n  )*0.5d0*ail 

c  x=b*srzi 

c  call  vvmval (l,n,x,vm,v) 

c  c40z«c40*srzi 

c  c31z* (c3l+c40z*x) /zeta 

c  c20z*(c20+c40z*3rzi*(nl+2)*0. 5d0)  *srzi 

c  cllz* (cll+c20z*x+c31z* (x*x+n*0 . 5d0) ) *srzi 

c  c00z*«  (c20z+c31z*x) *nl*0 . 5d0*srzi 

c  232  value*value+ (c00z*vm  +cllz*v  )  *ck 
if (deli j . eq. 0 . OdO) got o2 8 9 
if (lmax(kc) .eq. 0)goto290 
c00«akl*0. 3333333333333d0 
cl 1 *~c00 *bai*2 . OdO 
c2Q*delkl*0 . llllllllllllldO 
c22«c00*bai2-c20 
c20*c20+c22 
cll-cll-3.0d0*c22*ail 
c 

c  a<ri*ri/vs/rk*rl>b  <•>  r*r*<s/vs/ri*r j>b 
c 

lstrt-ldsrl (kc) 
lstop-ldspl (kc) 
do  124k»lstrt, lstop 
zeta*xi j+zlp (k) 

n*nlp (k) +2  ^ 
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nl-n+1 

exa-exp (-d* (1 . OdO-zetal/zeta) ) 

srzi-l.OdO/dsqrt (zeta) 

ck-clp (k) *exa* (arzi**n) *0 . 5d0*ail 

x»b*arzi 

call  wmval  (l,n,x,vm,  v) 

124  value«value+ { (c00+c20*nl*0 . 5d0/zeta) *vm+  (cll+c20*x*arzi) * 

#  arzi*v  ) *ck 

if (lmax (kc) . It . 3) goto290 
c 

c  a<ri*ri/vd/rk*rl>b  ■>  r*r* (k22*<y22/vd/rk*rl>b+k20*<y20/vd/rk*rl>b 
c 

d00»k22* (ak*al*ba**2*a**2*bax**2-ak*al*ba**2*a**2*bay**2+ 

#  10 . 0d0*ak*al*ba*a*bax**2-10 . 0d0*ak*al*ba*a*bay**2+35 . 0d0*ak* 

#  al*bax**2  -  35.d0*ak*al*bay**2  - 

#  2 . d0*ak*ba**3*a*bax*dxl  +  2 . d0*ak*ba**3*a*bay*dyl  - 

#  10 . 0d0*ak*ba**2*bax*dxl  +  10 . 0d0*ak*ba* *2*bay*dyl  - 

#  2 .d0*al*ba**3*a*bax*dxk  +  2 . d0*al*ba**3*a*bay*dyk  - 

#  10 . OdO*al*ba**2*bax*dxk  +  10 . 0d0*al*ba**2*bay*dyk  + 

#  2 . d0*ba**4*dxk*dxl  -  2.d0*ba**4*dyk*dyl-2.d0*ba**3*dkl*a*bax**2+ 

#  2 . d0*ba**3*dkl*a*bay**2  -  5 . d0*ba**2*dkl*bax**2  + 

#  5 . d0*ba**2*dkl*bay**2  )  /  (  ba**4*a**2  ) 
c 

c 

dmll— k22* (3.d0*ak*al*ba**2*a**2*bax**2- 

#  3 .d0*ak*al*ba**2*a**2*bay**2  +  30 . 0d0*ak*al*ba*a*bax**2  - 

#  30 . OdO*ak*al*ba*a*bay**2  +  105 . d0*ak*al*bax**2  - 

#  105.d0*ak*al*bay**2  -  6 . d0*ak*ba**3*a*bax*dxl  + 

#  6.d0*ak*ba**3*a*bay*dyl  -  30 . 0d0*ak*ba**2*bax*dxl  + 

#  30 . 0d0*ak*ba**2*bay*dyl  -  6 .d0*al*ba**3*a*bax*dxk  + 

#  6.d0*al*ba**3*a*bay*dyk  -  30 . 0d0*al*ba**2*bax*dxk  + 

#  30 . 0d0*al*ba**2*bay*dyk  -  ba**4*dkl*a**2*bax**2  + 

#  ba**4*dkl*a**2*bay**2  +  6 . d0*ba**4*dxk*dxl  - 

#  6.d0*ba**4*dyk*dyl  -  6 ,d0*ba**3*dkl*a*bax**2  + 

#  6 . d0*ba**3*dkl*a*bay**2  -  15.d0*ba**2*dkl*bax**2  + 

#  15 .d0*ba**2*dkl*bay**2  )  /  (  ba**4*a**3  ) 
c 

c 

dll»-k22* (2 . d0*ak*al*ba*a*bax**2-2 . d0*ak*al*ba*a*bay**2+ 

#  10 . 0d0*ak*al*bax**2-10 . 0d0*ak*al*bay**2-2 . d0*ak*ba**2*bax*dxi+ 

#  2 ,d0*ak*ba**2*bay*dyl  -  2 . d0*al*ba**2*bax*dxk  + 

#  2 . d0*al*ba**2*bay*dyk  -  ba**2*dkl*bax**2  +  ba**2*dkl*bay**2  )  / 

#  (  ba**4*a  ) 
c 

c 

d20-k22*ak*al* (bax**2-bay**2) / (ba**4) 

c 

c 

c  d20 
c 

d00-d00-k20* (ak*al*ba**2*a**2*bax**2+ak*al*ba**2*a**2*bay**2- 
I  2 . d0*ak*al*ba**2*a**2*baz**2  +  10 . OdO*ak*al*ba*a*bax**2  + 

#  10 . OdO*ak*al*ba*a*bay**2  -  20 . OdO*ak*al*ba*a*baz**2  + 

#  35 .d0*ak*al*bax**2  +  35 . d0*ak*al*bay**2  -  70 . 0d0*ak*al*baz**2- 

#  2.d0*ak*ba**3*a*bax*dxl  -  2 . d0*ak*ba**3*a*bay*dyl  + 

#  4  ,d0*ak*ba**3*a*baz*dzl  -  10 . OdO*ak*ba**2*bax*dxl  - 

#  10 . 0d0*ak*ba**2*bay*dyl  +  20 . OdO*ak*ba**2*baz*dzl  - 

#  2 ,d0*al*ba**3*a*bax*dxk  -  2 . d0*al*ba**3*a*bay*dyk  + 
t  4 .d0*al*ba**3*a*baz*dzk  -  10 . OdO*al*ba**2*bax*dxk  - 

#  10 . 0d0*al*ba**2*bay*dyk  +  20 . OdO*al*ba**2*baz*dzk  + 

#  2.d0*ba**4*dxk*dxl  +  2.d0*ba**4*dyk*dyl  -  4 ,d0*ba**4*dzk*dzl  - 

#  2 .d0*ba**3*dkl*a*bax**2  -  2 .d0*ba**3*dkl*a*bay**2  + 

#  4 .d0*ha**3*dkl*a*baz**2  -  5.d0*ba**2*dkl*bax**2  - 

#  5.o<  '»ba**2*dkl*bay**2  +  10 .  OdO*ba**2*dkl*baz**2  ) / (ba**4*a**2) 

)19 
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c 

c 

dmll-dmll+k20* (3.d0*ak*al*ba**2*a**2*bax**2+ 

#  3.d0*ak*al*ba**2*a**2*bay**2  -  6.d0*ak*al*ba**2*a**2*baz**2  + 

#  30 . OdO*ak*al*ba*a*bax**2  +  30 . OdO*ak*al*ba*a*bay**2  - 

#  60. 0d0*ak*al*ba*a*baz**2  +  105.d0*ak*al*bax**2  + 

#  105 .d0*ak*al*bay**2  -  210 . 0d0*ak*al*baz**2  - 

#  6.d0*ak*ba**3*a*bax*dxl  -  6 .d0*ak*ba**3*a*bay*dyl  + 

#  12 .d0*ak*ba**3*a*baz*dzl  -  30 . OdO*ak*ba**2*bax*dxl  - 

#  30 . OdO*ak*ba**2*bay*dyl  +  60 . 0d0*ak*ba**2*baz*dzl  - 

#  6.d0*al*ba**3*a*bax*dxk  -  6 . d0*al*ba**3*a*bay*dyk  + 

#  12 .d0*al*ba**3*a*baz*dzk  -  30 . 0d0*al*ba**2*bax*dxk  - 

#  30 . 0d0*al*ba**2*bay*dyk  +  60 . 0d0*al*ba**2*baz*dzk  - 

#  ba**4*dkl*a**2*bax**2  -  ba**4*dkl*a**2*bay**2  + 

#  2 .d0*ba**4*dkl*a**2*baz**2  +  6 . d0*ba**4*dxk*dxl  + 

#  6 . d0*ba**4*dyk*dyl  -  12 ,d0*ba**4*dzk*dzl  - 

#  6.d0*ba**3*dkl*a*bax**2  -  6.d0*ba**3*dkl*a*bay**2  + 

#  12 .d0*ba**3*dkl*a*baz**2  -  15 . d0*ba**2*dkl*bax**2  - 

#  15.d0*ba**2*dkl*bay**2  +  30 . OdO*ba**2*dkl*baz**2  )  / 

#  (  ba**4*a**3  ) 
c 

c 

c 

dll-dll+k20* (2 . d0*ak*al*ba*a*bax**2+2 . d0*ak*al*ba*a*bay**2- 

#  4.d0*ak*al*ba*a*baz**2  +  10 . 0d0*ak*al*bax**2  + 

#  10 . OdO*ak*al*bay**2  -  20 . 0d0*ak*al*baz**2  - 

#  2 .d0*ak*ba**2*bax*dxl  -  2 . d0*ak*ba**2*bay*dyl  + 

#  4 .d0*ak*ba**2*baz*dzl  -  2 .d0*al*ba**2*bax*dxk  - 

#  2.d0*al*ba**2*bay*dyk  +  4 .d0*al*ba**2*baz*dzk  - 

#  ba**2*dkl*bax**2  -  ba**2*dkl*bay**2  +  2 . d0*ba**2*dkl*baz**2  ) 

#  /  {  ba**4*a  ) 
c 

c 

c 

d20=d20-k20*ak*al* (bax**2+bay**2-2.d0*baz**2) / (ba**4) 
c 

lstrt=ldsr3 (kc) 
l3top*ldsp3 (kc) 
do  237k=lstrt, lstop 
zeta*xi j+zlp (k) 
n«nlp (k) +2 
nl=n+l 

exa=exp (-d* (1 . OdO-zetal/zeta) ) 

3rzi«l . OdO/dsqrt (zeta) 

ck*clp (k) *exa* (srzi**n) *0 . 5d0*ail 

x*b*srzi 

call  vvmval (l,n,x, vm,v) 

237  value=»value+ ( (d00+dll*srzi+d20*  <b*srzi+ (n+3) /2 . OdO) / (2 . OdO 

#  *zeta) ) * (n+1) *srzi*vm/2 . OdO  + (d00*b/ (2 . 0d0*zeta) +dmll+ 

#  dll* (b*b/ (2 . 0d0*zeta) +n) +d20*b* (b*b/ (4 . OdO* zeta) +n+l . 5d0) 

#  / (2 . 0d0*zeta*zeta) ) *v  ) *ck 
go  to  290 

c 

c  a<ri*r j/vd/rk*rl>b  ,  i  .ne.  j  ->  r*r*<yi j/vd/rk*rl>b 

c  where  yij«x*y/r*r  ,  x*z/r*r  or  y*z/r*r. 

c 

289  d00«(  ak*al*ba**2*a**2*ai*a j+10 . 0d0*ak*al*ba*a*ai*a j+ 

#  35 . d0*ak*al*ai*a j  -  ak*ba**3*a*ai*del jl  -  ak*ba**3*a*a j*delil  - 

#  5 . d0*ak*ba**2*ai*del jl  -  5.d0*ak*ba**2*a j*delil  - 

#  al*ba**3*a*ai*del jk  -  al*ba**3*a*a j*delik  - 

#  5.d0*al*ba**2*ai*del jk  -  5.d0*al*ba**2*aj*delik  + 

#  ba**4*delik*del jl  +  ba**4*delil*del jk  - 

#  2 .d0*ba**3*delkl*a*ai*a j  -  5.d0*ba**2*delkl*ai*a j  ) / (ba**4*a**2) 
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c#  dimll 
c 

dmll— (3.d0*ak*al*ba**2*a**2*ai*a j+ 

#  30 . OdO*ak*al*ba*a*ai*a j  +  105 .dO*ak*al*ai*a j  - 

#  3.d0*ak*ba**3*a*ai*deljl  -  3.d0*ak*ba**3*a*a j*delil  - 

#  15.d0*ak*ba**2*ai*del jl  -  15 .d0*ak*ba**2*a j*delil  - 

#  3.d0*al*ba**3*a*ai*deljk  -  3.d0*al*ba**3*a*a j*delik  - 

#  15.d0*al*ba**2*ai*deljk  -  15 .d0*al*ba**2*a j*delik  - 

#  ba**4*delkl*a**2*ai*a j  +  3 .d0*ba**4*delik*del jl  + 

#  3.d0*ba**4*delil*del jk  -  6.d0*ba**3*delkl*a*ai*a j  - 

#  15.d0*ba**2*delkl*ai*a j  )  /  (  ba**4*a**3  ) 
c 

c#  dill 
c 

dll—  (2  .d0*ak*al*ba*a*ai*a  j+10 . 0d0*ak*al*ai*a j- 

#  ak*ba**2*ai*del jl  -  ak*ba**2*a j*delil  -  al*ba**2*ai*del jk  - 

#  al*ba**2*a j*delik  -  ba**2*delkl*ai*a j  )  /  (  ba**4*a  ) 
c 

c#  di20 
c 

d20«ak*al*ai*a j/ (ba**4) 
c 

c 

lstrt-ldsr3 (kc) 
lstop*ldsp3  (kc) 
do  288k*lstrt, lstop 
zeta*xi j+zlp (k) 
n*nlp (k) 
nl«n+l 

exa*exp (-d* (1 . OdO-zetal/zeta) ) 

srzi*l . 0d0/d3qrt (zeta) 

ck-clp (k) *exa* (srzi**n) *0 . 5d0*ail 

x«b*srzi 

call  vvmval (l,n,x, vm, v) 

288  value-value+ ( (d00+dll*srzi+d20* (a*srzi+n+3 . OdO) / (2 . OdO 

#  *zeta)  ) *nl*3rzi*vm/2 . OdO  + (d00*a/ (2 . 0d0*zeta)  +  dmll  + 

#  dll  *  (a*a/ (2 . OdO* zeta) +n)  / (2 . 0d0*zeta)  + 

#  d20  *  a* (a*a/ (4 . 0d0*zeta) +n+l . 5d0) 

#  / (2 . 0d0*zeta*zeta) ) *v  )  *ck 
c 

290  xbaa=value 

291  return 

1  write(60,2) 

2  format (lhl, ///, 20x, 18hfatal  purity  error) 
stop 

end 

subroutine  vbca 
c  version  #1  feb,  1985 
c 

implicit  double  precision (a-h, o-z) 

dimension  si 00 (5) ,  simll (5) ,  piOO (5) , pimll (5) , pill (5) ,  diOO  (5) , 

#  dimll (5) , dill (5) ,di20 (5) , s jOO (5) , s jmll (5) ,pj00 (5) , 

#  p jmll (5)  , p jll (5) ,  djOO (5) , djmll (5)  ,djll{5) ,dj20(5) 
c 

c  common  block  for  ddmx  test 
c 

common/ test /ddtest 

common/bfcom/xcab, ityp, jtyp, zetl, zet2, kc, idum, caa (3) ,  ca, 

#  baa (3)  ,ba,daa<3)  , dasq, phase, zval 

common/ int2 /nip (200) , clp (200) , zip (200) , lstrl (20) , lstr2 (20) , 

1  lstr3 (20) , lstr4 (20) ,lstpl (20) ,lstp2 (20) , lstp3 (20) , lstp4 (20) , 
1  ldsrl (20) , ldsr2 (20) , ldsr3 (20) , ldspl (20) , ldsp2 (20) , ldsp3 (20) , 
1  dsmx  (20)  ,  dpmx  (20) ,  ddmx  (20) ,  xmx  (20) ,  Imax  (20) 

IV 


lopas . s nb 


Fri  Apr  5  11:22:53  1991 


104 


common/cnlll2/cm211, cmllO, cmlOl,  cOOO, cOll, cl01,cll0,c200,c211, 
#  c301,c310, c400,c411,xi j, aht,bht,d,  inttyp, ldstr, ldstp 

common/aaacom/zeta 
common/erf p/b, xi jp 

c  data  fourpi/12 . 56637060d0/  deleted 

c  data  srpi.4/0 . 4431134627265d0/  deleted 

data  srpi/1 . 7724 538 5090d0/ 
data  pi/3 . 141 5926535897932384 6d0/ 
c 
c 

c  initialization  of  parameters 
c 

ia-0 

ja-0 

ka-0 

la-0 

c 

xi j»zetl+zet2 
xi jp-xij 
lm»lmax (kc) +1 
lstrlm-lstr4 (kc) 
lstplm«lstp4 (kc) 

3  delij-O.OdO 
value-0 . OdO 
aht«ca*zetl 
bht=ba*zet2 
xl»aht*2 . OdO 
x2-bht*2 . OdO 
d— 0 . 5d0*  (xl*ca+x2*ba) 
c 

go  to  (11,12,13,14, 15, 16,17,18,19,20) , jtyp 
go  to  4 

11  inttyp-1 
go  to  100 

12  ia-1 

go  to  21 

13  ia-2 

go  to  21 

14  ia-3 

go  to  21 

15  ia-1 
ja-1 

deli j-0 . 333 3 33 33 33333 33d0 
go  to  27 

16  ia-2 
ja-2 

deli j-0. 333333333333333d0 
go  to  27 

17  ia-3 
ja-3 

deli j-0. 333333333333333d0 
go  to  27 

18  ia-1 
ja-2 

deli j-0 . OdO 
go  to  27 

19  ia-1 
ja-3 

deli j-0 . OdO 
go  to  27 

20  ia-2 
ja-3 

delij-O.OdO 
go  to  27 

I  s-t- 
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21  go  to  (22,23,24,25), ityp 

22  ai-baa(ia) 
inttyp-2 
go  to  100 

23  ja-1 

go  to  26 

24  ja-2 

go  to  26 

25  ja-3 

go  to  26 

26  ai-baa(ia) 
aj-caa ( ja) 
inttyp-3 
ai j«ai*a j 
deli j”0 . OdO 

if (ia. eq. ja) deli j-0 . 33 333 3 333 33 3 33 3d0 
go  to  100 

27  go  to  (31, 32, 33, 34, 35, 36, 37, 38, 39, 40), ityp 

28  ai-baa(ia) 
a j-baa ( ja) 
ak»caa  (lea) 
ai j-ai*a j 
ai jk-ai j*ak 
inttyp-5 
delik-0 . OdO 
del jk-0 .  OdO 

if (ia.eq. ka) delik-0 . 333 3 33333333 3 33d0 
if ( ja. eq. ka) del jk=0 . 333333333333333d0 
c2t« (ai*del jk+a j*delik+ak*deli j) 
go  to  100 

29  ai-baa(ia) 
aj«baa(ja) 
ak=caa (ka) 
al-caa (la) 
inttyp-6 
ai j-ai*a j 
aik«ai*ak 
ail*ai*al 
ajk«a j*ak 
a jl»a j*al 
akl«ak*al 

ai jkl-ai j*akl 
delik»0 . OdO 
delil-0 . OdO 
del jk-0. OdO 
deljl-O.OdO 

if (ia.eq. ka) delik-0 . 333 3 33 3 333 33 3 3 3d0 
if (ia.eq. la) delil-0.333333333333333d0 
if (ja.eq.ka)deljk-0.333333333333333d0 
if ( ja .eq. la) del j 1-0 . 333333333333333d0 
dels-deli j*delkl+delik*del jl+delil*del jk 
c2t-  aik*del jl+ail*del jk+a jk*delil+a jl*delik 
go  to  100 

31  ai-baa(ia) 
a j-baa (ja) 
ai j-ai*a j 
inttyp-4 
go  to  100 

32  ka-1 

go  to  28 

33  ka-2 

go  to  28 

34  ka-3 

go  to  28 
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35  ka-1 
la-1 

delkl-0 . 333333333333333d0 
go  to  29 

36  ka-2 
la-2 

delkl-0. 333333333333333d0 
go  to  29 

37  ka-3 
la-3 

delkl-0. 333333333333333d0 
go  to  29 

38  ka-1 
la-2 

delkl-0. OdO 
go  to  29 

39  ka-1 
la-3 

delkl-0 . OdO 
go  to  29 

40  ka-2 
la-3 

delkl-0 . OdO 
go  to  29 
c 

100  if  (dasq.gt.l.0d-16)goto200 
c 

go  to  <101, 102, 103, 103, 105, 106), inttyp 

101  cO-l.OdO 
go  to  160 

102  cO— ai 

go  to  160 

103  c0«aij 
c2=*deli  j 
go  to  170 

105  cO— aijk 
c2— c2t 
go  to  170 
c 
c 

160  if (cO .eq. 0) goto400 
vcO-O . OdO 

do  163k»lstrlm, latplm 
zeta-xi j+zlp (k) 
ck-clp(k) 
n*nlp (k) 

vc0«vc0-zval*clp (k) *dsqrt (zip (k) /zeta) /  (2 . 0d0*xi j) 
c  vcO-vcO+fa (n) *ck 

163  continue 

xcab-phase*c0*vc0 
go  to  400 
c 

170  if (cO .eq. 0 . OdO . and. c2 .eq. 0 . OdO) goto400 
vcO-O . OdO 
vc2-0 . OdO 

do  173k-lstrlm, lstplm 
zeta-xi j+zlp (k) 
ck-clp(k) 
n-nlp(k) 

if (c2 .eq. 0 . OdO) gotol72 

vc2-vc2-zval*ck*dsqrt (zlp(k) /zeta) * (3 . 0d0*xi j 
#  +2.0d0*clp(k) ) / (4 . 0d0*xi j*xi j*zeta) 

c  vc2-vc2+fa (n+2) *ck 

172  if (c0.eq.0.0d0)gotol73 
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vcO-vcO-zval*clp(k)  *dsqrt  (zlp(k)  /zeta)  /  (2. 0d0*xij) 
c  vcO-vcO+fa (n) *ck 
173  continue 

xcab-phase* (c2*vc2+c0*vc0) 
go  to  400 
c 
c 

106  cO-aijkl 

c2  -(ai j*delkl+c2t+akl*deli j) 

c4-dels*0.6d0 

vcO-O.OdO 

vc2-0. OdO 

vc4-0.0d0 

do  183k-lstrlm, lstplm 
zeta-xi j+zlp (k) 
ck-clp (k) 
n-nlp (k) 

vc4-vc4-zval*ck*dsqrt (zlp(k) /pi) * (fa (4) +2. OdO* 

1  (fa (2) +fa (0) /xi j) /xi j) /xi j 
c  vc4-vc4+fa (n+4) *ck 

if (c2.eq.0.0d0)gotol82 

vc2-vc2-zval*ck*dsqrt (zip (k) /zeta) * (3. 0d0*xi j 
#  +2 . 0d0*clp (k) ) / (4 . 0d0*xi j*xi j*zeta) 

c  vc2*vc2+fa (n+2) *ck 

182  if (cO.eq. 0 . OdO) gotol83 

vc0-vc0-zval*clp (k) *dsqrt (zip (k) /zeta) / (2 . 0d0*xi j) 
c  vc0«vc0+fa (n) *ck 

183  continue 

xcab-phase* (c2*vc2+c0*vc0+c4*vc4) 
go  to  400 

c 

c 

200  da=dsqrt (dasq) 
b=da*xi j 
a-b*2.0d0 
ail-1. OdO/a 
dl-b*da 

srab-dsqrt (xi j) 

go  to  (210,220,230,230,240,250) ,inttyp 

c  sc - 3b 

210  c00-l. OdO 

211  vcOO-O.OdO 

do  212k-lstrlm, lstplm 
zeta-xi j+zlp (k) 
n-nlp (k) 

exa-dsqrt (zlp(k) / (xi j+zlp (k) ) ) 
x»da*srab*exa 
call  wmval  (2,n,x,vml,  vmO) 
vc00-vc00-zval*clp (k) *vm0 

212  continue 

c  write (60, 218) vcOO 

c  218  formatdx,'  vbca  <a/core/s>-  ',dl5.8) 
c  if ( (lstrlm+2)  .eq.  lstplm)  goto  219 

c  do  213  k-lstrlm+2, lstplm 

c  zeta-xi j+zlp(k) 

c  n-nlp (k) 

c  exa-exp(-dl* (1. OdO -xij/ zeta) ) 

c  srzi-l . OdO/dsqrt (zeta) 

c  ck-clp(k) *exa* (srzi**n  )*0.5d0*ail 

c  x-b*srzi 

c  call  wmval  (0,n,x,vm,v) 

c  213  vcOO  -vc00+ck*vm 
xcab-phase* vc 00 
c  write(60,2227)xcab 

/*tf" 


lopas . sub 


fri  Apr  5  11:22:53  1991 


108 


c2227  format (lx, '  exiting  <a|vmax|s>  xcab-' , f 14 . 8) 
go  to  400 
c  ac - pb 

220  cOO— ai 
cll-daa (ia) /da 

221  if (cOO.eq. 0. OdO. and. cl 1 .eq. 0 . OdO) goto400 
vcOO-O. OdO 

vcll-O.OdO 

do  222k-lstrlm, lstplm 
zeta-xi j+zlp(k) 
exa-dsqrt(zlp{k) /zeta) 
x-da*srab*exa 
call  vvmval (2,2, x,vml,vm0) 
vc00*vc00-zval*clp (k) *vmO 
if (ell) 223, 222, 223 
223  vcll^vcll-zval^clp (k) *vml 

222  continue 

c  write(60,11992)vc00,vcll 

cll992  formatdx,'  mO  »  ',dl5.8,'  r*ml  -  ',dl5.8) 
xcab-phaae* (c00*vc00+cll*vcll) 
c  write (60, 1829) xcab 

c  1829  formatdx,'  vbca  <s/core/p>=' , dl5 . 8) 
go  to  400 

c  pc - pb  or  ac - db 

230  di-daa (ia) /da 
dj«daa( ja) /da 
c20-deli j 
value-0 . OdO 
cOO-ai j 

ell—  (di*a j+dj*ai) 
c22» di*dj-c20 
c20-c20+c22 
cll-cll-3.0d0*c22*ail 

if  (cOO.eq. 0. OdO. and. c20.eq. 0 . OdO . and. cl 1 . eq. 0 . OdO) goto400 

bvml-0 . OdO 

bvm0»0 . OdO 

bvm2=*0 .  OdO 

bvm3»0 . OdO 

do  232k-lstrlm, lstplm 
zeta»xi j+zlp (k) 
exa=dsqrt (zip (k) /zeta) 
x-da*srab*exa 
call  vvmval (2,2,x, vml,vm0) 
cOOvmO-cOO*vmO 
cllvml-cll*vml 
bvmO»bvmO-zval*clp (k) *vm0 
bvml-bvml-zval*clp  (k)  *vml 
c  write (60,2714) clp(k> , zip (k) ,x 

c  2714  formatdx,'  clp (k) -' ,dl5 . 8, '  zip  (k) -' ,  dl5. 8, '  x-',dl5.8) 
call  vvmval (2,  4,x,  vml, vmO) 
bvm2*bvm2-zval*clp (k) *vm0 
bvm3-bvm3-zval*clp (k) "vml 

232  value«value-zval*clp (k) * (c00vm0+c20*vm0+cllvml) 
c  write (60, 18823) bvmO , bvml , bvm2 , bvm3 

cl8823  formatdx,'  mO  -  ',dl5.8,'  r*ml  *  ',dl5.8 
c  #  ,/,'  r*r*m0  -  ',dl5.8,'  r*r*r*ml-  ',dl5.8) 
xcab-phase*value 
c  write (60, 7251) xcab 

c7251  format  (lx, '  <p/core/p>  -',dl5.8) 
go  to  400 

c  pc - db 

240  di-daa (ia) /da 
dj«daa( ja) /da 

dk-daa (ka) /da  M 
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cOO— ai jk 
c20— c2t 

c31-(dk*delij+dj*delik+di*deljk)  *0.6d0 
c33-di*dj*dk-c31 

c22— (a j*di*dk+ai*dj*dk+ak*di*dj+c20) 

cll-ai*a j*dk+ak*a j*di+ak*ai*dj 

c31-c31+c33 

c22-c22-5.0d0*c33*ail 

c20«c20+c22 

cll-cll-3. 0d0*c22*ail 

value-0. OdO 

do  243k-lstrlm, lstplm 

zeta-xi j+zlp (k) 

exa-dsqrt (zip (k) / zeta) 

x-da*srab*exa 

call  vvmval (2,2,x, vml,vm0) 

c00vm0-c00*vm0 

c 1 1 vml - c 1 1 * vml 

call  vvmval  (2, 4,x,  vml,  vmO) 

value-value-zval*clp (k) * (c00vmQ+cllvml+c20*vm0+c31*vml) 

243  continue 

c  do  242  k-lstrlm, lstplm 

c  n-nlp(k) 

c  zeta-xi j+zlp (k) 

c  nl-n+1 

c  exa-exp (-dl* (1 . OdO-xi j/zeta) ) 

c  srzi-1 . OdO/dsqrt (zeta) 

c  ck*clp (k) *exa* (srzi**n  ) *0 . 5d0*aibca3070 

c  srzi-1. OdO/dsqrt (zeta) 

c  ck-clp(k) *exa* (srzi**n  )*0.5dQ*ail 

c  x-b*srzi 

c  call  vvmval (l,n,x,vm,v) 

c  c31z-c31/zeta 

c  c20z-c20*srzi 

c  cllz- (cll+c20z*x+c31z* (x*x+n*0 . 5d0) ) *srzi 

c  c00z-c00+ (c20z+c31z*x) *nl*0 . 5d0*srzi 

c  242  value-value+ (c00z*vm  +cllz*v  )  *ck 
xcab-phase* value 
go  to  400 

c  dc - db 

250  dai-l.OdO/da 
di-daa (ia) *dai 
dj-daa ( ja) *dai 
dk-daa (ka) *dai 
dl-daa (la) *dai 
dij=di*dj 
dik«di*dk 
dil-di*dl 
djk»dj*dk 
djl-dj*dl 
dkl-dk*dl 
adi j-ai*dj 
adkl-ak*dl 
dai j-di*a j 
dakl«dk*al 
addai j-adi j+dai j 
addakl-adkl+dakl 
cOO-aijkl 

ell—  (ai j*addakl+akl*addai j) 
c20  - (ai j*delkl+c2t+akl*deli j) 

c22t-ai j*dkl+aik*d jl+ail*djk+a jk*dil+a jl*dik+akl*di  j 
c22-c22t-c20 

c31-- (deli j*addakl+delkl*addai j+delik* (a j*dl+al*dj) +delil* (a j*dk+ 
»  ak*dj) +del jk* (ai*dl+al*di) +del jl* (ai*dk+ak*di) ) *0 . 6d0 
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c33—  (di  j*addakl+dkl*addai j+c31) 
c40-dela*0 . 6d0 

c42t-  (dell j*dkl+delik*djl+delil*djk+del jk*dil+del jl*dik+delkl*di j) 

c42«(c42t-dela*2.0d0)*0.4285714285714d0 

c44-di j*dkl+ (dela*0 . 6d0-c42t) *0 . 4285714285714d0 

c42-c42+c44 

c33-c33-7 . 0d0*c44*ail 

c40-c40+c42 

c31-c31+c33-3.0d0*c42*ail 

c22-c22-5.0d0*c33*ail 

c20-c20+c22 

cll-cll-3 . OdO*c22*ail 

value-0 . OdO 

do  353k-latrlm, latplm 

zeta-xi j+zlp (k) 

exa-daqrt (zlp(k) /zeta) 

x-da*arab*exa 

call  wmval  (2,2,x,vml,vm0) 

c00vm0-c00*vm0 

cllvml-cll*vml 

call  wmval  (2,  4,x,  vml,  vmO) 

c20vm0-c20*vm0 

c31vml-c31*vml 

call  wmval  (2,  6,x,vml,  vmO) 

value«value-zval*clp (k) * (c00vm0+cllvml+c20vm0+c31vml+c40*vm0) 

353  continue 

c  do  352  k«lstrlm, latplm 

c  n-nlp(k) 

c  zeta-xi j+zlp (k) 

c  nl-n+1 

c  exa-exp(-dl* (1 . OdO-xi j/zeta) ) 

c  srzi»l . OdO/daqrt (zeta) 

c  ck-clp (k) *exa* (srzi**n  )*0.5d0*ail 

c  x-b*arzi 

c  call  wmval  (l,n,x,vm,  v) 

c  c40z-c40*srzi 

c  c31z- (c31+c40z*x) /zeta 

c  c20z« (c20+c40z*arzi* (nl+2) *0 . 5d0) *srzi 

c  cllz- (cll+c20z*x+c31z* (x*x+n*0 . 5d0) ) *srzi 

c  c00z-c00+ (c20z+c31z*x) *nl*0 . 5d0*srzi 

c  352  value-value+ (c00z*vm  +cllz*v  ) *ck 
xcab-phase* value 
go  to  400 
c 

400  if (lmax(kc) .It. 1) return 
if (damx (kc) +d) 700,700,401 

401  continue 

ldatr  -ldarl(kc) 
ldatp  -ldapl(kc) 

go  to  (410, 402, 430,  404 , 405,  406) , inttyp 

402  cOOb— ai 
go  to  420 

404  cOOb-aij 
c20b-c00b/ (ba*ba) 

cl lb— 2 . 0d0*c00b/ba-3 . OdO* <c20b-deli j) /x2 
if (cOOb.eq. 0 . OdO . and. cl lb. eq. 0 . OdO) goto700 
go  to  435 

405  cOOb-aij 
c20b-c00b/(ba*ba) 

cl lb— 2 . 0d0*c00b/ba-3. OdO* <c20b-deli j) /x2 
if (cOOb.eq. 0 . OdO . and. cllb.eq. 0 . OdO) goto700 
go  to  440 

406  cOOb-aij 
c20b-c00b/ (ba*ba) 
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cllb— 2.0d0*c00b/ba-3.0d0* (c20b-deli j) /x2 
if (cOOb.eq. 0 . OdO .and. cllb. eq. 0 . OdO) goto700 
go  to  450 
c  sc — s — sb 
410  cOOO-l.OdO 
go  to  500 
c  sc — s — pb 
420  c000«c00b 

if (c00b)423,700f 423 
423  clOl— cOOb/ba 
go  to  500 
c  pc — s — pb 

430  c000*aij 

431  if (c000)433,700,433 
433  clOl— cOOO/ba 

cllO— cOOO/ca 
c211— clOl/ca 
go  to  500 
c  sc — s — db 
435  c000=c00b 
c200a»c20b 
cl01=cllb 
go  to  500 
c  pc — s — db 
440  cOOc— ak 

if (cOOc.eq. 0 . OdO) goto700 
c000»c00c*c00b 
cl01*c00c*cllb 
c200=«c00c*c20b 
cllO— cOOO/ca 
c211— clOl/ca 
c3io— c200/ca 
go  to  500 
c  dc — s — db 
450  c00c«akl 

c20c*c00c/ (ca*ca) 

cllc— 2 . 0d0*c00c/ca-3 . OdO* (c20c-delkl) /xl 
if (cOOc.eq. 0 . OdO . and. cllc . eq. 0 . OdO) goto700 
c000=c00c*c00b 
c200«c00c*c20b+c20c*c00b 
c301*c20c*cllb 
c310»cllc*c20b 
cl01*c00c*cllb 
cll0*cllc*c00b 
c400»c20c*c20b 
c211-cllc*cllb 
go  to  500 
c 

500  call  vbcas(xcab) 
c  write (60, 3427) xcab 

c3427  format(lx, '  xcab  after  <s I s>' , dl5 . 9) 
c 

700  if (lmax (kc) . It . 2) return 

if (dpmx (kc) +d* (ca+ba) **2)1925, 1925, 701 

701  ldstr  -ldsr2(kc) 
ldstp  *ldsp2(kc) 
cba-ca*ba 

cbd- (caa (1) *baa (1 ) +caa (2) *baa (2) +caa (3) *baa (3) ) /cba 
go  to  (710,720,730,740,750,760) , inttyp 
c 

C  3C — p — sb 

710  cOll-cbd 

711  if (c011)713, 1925, 713 
713  vcOll-O.OdO 
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go  to  800 
c  sc — p — pb 

720  cOll— ai*cbd 
cllO— cOll/ba 

c011-c011-3. OdO* (cllO-caa  <ia) *0 . 333333333333333d0/ca) /x2 
if (cOll .eq. 0. OdO .and. cl 10 .eq. 0 . OdO) gotol925 
go  to  800 
c  pc — p — pb 

730  c200«delij*0.333333333333333d0 
baa2=baa ( ja) *ai 
caa2*caa (ia) *a j 
clOl— baa2/  (3 . 0d0*ba*ba) 
cllO— caa2/  (3 . 0d0*ca*ca) 
cc200=ai j*cbd/cba 
if (c200)729,728,729 

728  if(cl01.eq.0. OdO . and. cllO . eq. 0 . OdO . and. cc200 . eq. 0 . OdO) gotol925 

729  continue 

dll0=3 . OdO* (cc200+cl01) /xl 
dl01=3.0d0* (cc200+cll0) /x2 

c011=cba*cc200+dll0*ba+dl01*ca+9 . OdO* (cc200+c200+cll0+cl01) / (xl* 
#  x2) 

cllO— ca*cc200-dll0 
clOl— ba*cc200-dl01 
c200=cc200 
go  to  800 
c  sc — p — db 

740  c011=ai j*cbd 

cl  10=*-  (caa  (ia)  *a  j+caa  ( ja)  *ai)  /  (3 . 0d0*ca) 
c211— 0 . 6d0*  (cllO/ba-deli  j*cbd) 
cll2— 2.0d0*c011/ba-cll0 
c213=*c011/  (ba*ba)  -c211 
c211-c211+c213 
cll2=cll2-5. OdO*c213/x2 
cllO=cllO+cll2 
c011=c011-3.0d0*cll2/x2 
go  to  800 
c  pc — p — db 

750  c011=-ai jk*cbd 

cl01t=baa (ka) / (3 . 0d0*ba) 
cl01=*cl01t*ai  j 

cl 10=  ak* (caa ( ja) *ai+caa (ia)*aj)/(3. 0d0*ca) 

c200=-0 . 333333333333 33 3d0* (ai*del jk+a j*delik) 

c301  —  0.6d0*  (c200/ba-deli  j*cl01t) 

cl21=-c011/ca-cl01 

cll2=-2 . 0d0*c011/ba-cll0 

c202— 2.0d0*cl01/ba-c200 

c303=cl01/ (ba*ba) -c301 

c211=-0 . 6d0* (cllO/ba+deli j*ak*cbd) 

c213=c011/ (ba*ba) -c211 

c220— cll0/ca-c200 

c321— c211/ca-c301 

c222— cll2/ca-c202 

c323— c213/ca-c303 

c222=c222-5. 0d0*c323/x2 

c321=c321+c323 

c202=c202-5.0d0*c303/x2 

c202=c202+c222 

C112-C112-3. 0d0*c222/xl 

cll2»cll2-5. 0d0*c213/x2 

c301*c301+c303+c321 

c211=c211-3.0d0*c321/xl 

c211=c211+c213 

c200-c202+c220+c200 

cl01=cl01-3.0d0*c2C2/x2 
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cl01-cl01+cl21 
cllO-cllO-3. 0d0*c220/xl 
cllO-cllO+cll2 

c011-c011-3.0d0*cll2/x2-3.0d0*cl21/xl 
go  to  800 
c  dc — p — db 

760  cOll-ai jkl*cbd 

cllOt-ai*caa ( ja) +a j*caa (ia) 

cllO— akl*cll0t/  (3 . 0d0*ca) 

cl01t=ak*baa (la) +al*baa (ka) 

clOl— aij*cl01t/  (3 . 0dQ*ba) 

cl  12— 2 . 0d0*c011/ba-cll0 

cl21— 2.0d0*c011/ca-cl01 

c211a— 0 . 6d0* (cll0/ba-akl*deli j*cbd) 

c211b—  0. 6d0*  (clOl/ca-ai j*delkl*cbd) 

c211-c211a+c211b 

c213-c011/ (ba*ba) -c211a 

c231*c011/ (ca*ca) -c211b 

c200”c2t*0 . 333333333333333d0 

c220— 2.0d0*cll0/ca-c200  - 

c202— 2 . 0d0*cl0l/ba-c200 

c310— (3.0d0*c200+delkl*cll0t) / <5.0d0*ca) 

c301— <3.0d0*c200+delij*cl01t)/ (5. 0d0*ba) 

c330-cll0/ (ca*ca) -c310 

c303=cl01/ (ba*ba) -c301 

c222— 2.0d0*cll2/ca-c202 

c321— 2 . 0d0*c211a/ca-c301 

c312— 2.0d0*c211b/ba-c310 

c323— 2 . 0d0*c213/ca-c303 

c332— 2 . 0d0*c231/ba-c330 

c4U  — 0. 6d0* (c301/ca+c310/ba) -0 . 36d0* (c200/cba-deli j*delkl*cbd) 

c431=c211a/ (ca*ca) -c411 

c413-c211b/ (ba*ba) -c411 

c433=*c231/  (ba*ba)  -c431 

c431=c431+c433 

c332=c332-5. 0d0*c433/x2 

c411=c411+c413+c431 

c312»c312-5. 0d0*c413/x2 

c312*c312+c332 

c321»c321-5.0d0*c431/xl 

c222»c222-5.0d0*c332/xl 

c220»c220-5.0d0*c330/xl 

c222=c222-5.0d0*c323/x2 

c321-c321+c323 

c202*c202-5 . 0d0*c303/x2 

c202-c202+c222 

cll2*cll2-3 . 0d0*c222/xl 

Cll2-cll2-5.0d0*c213/x2 

cl21«cl21-5.0d0*c231/xl 

c310»c3l0+c312+c330 

c301«c301+c303+c321 

c211=c211-3. 0d0*c312/x2 

c211-c211-3.0d0*c321/xl 

c211*c211+c213+c'31 

c200*c202+c220+c200 

cl01=cl01-3. 0d0*c202/x2 

cl01«cl01+cl21 

cllO^c 110-3. 0d0*c220/xl 

cll0-cll0+cll2 

c011=c 011-3. 0d0*cll2/x2-3 .0d0*cl21/xl 
go  to  800 
c 

800  call  vbcap(xcab) 
c  write (60, 4447?) xcab 
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C44472  format (lx,'  xcab  after  <p!p>  ',dl5.9) 

c 

c 

1925  if (lmax (kc) . It . 3) return 
c 

c  if(ddmxOcc)  +  d*  (ca  +  ba)**2)  1950,1950,901 

buftest-d* (ca+ba) **2 
testcab-xcab 
901  ldstr  «ldsr3(kc) 
ldstp  -ldsp3(kc) 
a«zetl*2 . 0d0*ca 
b-zet2*2 . 0d0*ba 
x22-dsqrt ( 1 5 . OdO ) /2 . OdO 
x21»2.0d0*x22 
x20-dsqrt ( 5 . OdO ) /2 . OdO 
x2ml»x21 
x2m2=x21 
ax»caa  (1) 
ay=caa (2) 
az-caa (3) 
bx-baa (1) 
by-baa (2) 
bz-baa (3) 
dax=ax/ca 
day-ay/ca 
daz*az/ca 
dbx-bx/ba 
dby-by/ba 
dbz=bz/ba 
bc-ba 
ac-ca 

daxs-dax*dax 
days=day*day 
dazs-daz*daz 
dbx  s -dbx  *  dbx 
dbys-dby*dby 
dbzs-dbz*dbz 
cm211=0 . OdO 
cmllO-O . OdO 
cml01-0 . OdO 
cOOO-O.OdO 
c011-0 . OdO 
clOl-O. OdO 
cllO-O. OdO 
c200-0 . OdO 
c211-0 . OdO 
c301-0.0d0 
C310-0 . OdO 
C400-0 . OdO 
C411-0 . OdO 

if  (inttyp. ne . 3) goto902 
ak-a  j 
ka=  ja 

c  delik-delij 
902  bi-ai 
ib«ia 
jb-ja 
bj-aj 
dbi-bi/ba 
db  j-b  j/ba 
dak-ak/ca 
dal-al/ca 

if (deli j . ne . 0 . OdO) di j-1 . OdO 

if  (delkl .  ne .  0 .  OdO)  dkl-1 .  OdO  I  Ci 
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dxi«0 . OdO 
dx j-0 . OdO 
dxk-O.OdO 
dxl-O.OdO 
dyi“0 . OdO 
dyj*0.0d0 
dyk-0 . OdO 
dyl*0 . OdO 
dzi»0 . OdO 
dz j«0 . OdO 
dzk*0 . OdO 
dzl»0. OdO 

go  to  (905, 910,915) , ib 
go  to  920 
905  dxi-l.OdO 
go  to  920 
910  dyi-l.OdO 
go  to  920 
915  dzi-l.OdO 
920  go  to  (925, 930, 935) , jb 
go  to  940 
925  dxj-l.OdO 
go  to  940 
930  dyj-l.OdO 
go  to  940 
935  dz  j=l . OdO 
940  goto  (945,950,955) ,ka 
go  to  960 
945  dxk-l.OdO 
go  to  960 
950  dyk-l.OdO 
go  to  960 
955  dzk-l.OdO 
960  go  to(965,970,975),la 
go  to  980 
965  dxl*l . OdO 
go  to  980 
970  dyl-l.OdO 
go  to  980 
975  dzl=l . OdO 
c 

980  go  to  (810, 810,  820,  810, 820, 830) , inttyp 
c 

810  siOO (1) «x22* (daxs-days) 

3imll (1)  *■- 3. 0d0*si00 (1) /a 
si 00 (2) »x21*dax*daz 
simll (2) *-3 . 0d0*si00 (2) /a 
siOO <3)-x20* (3. 0d0*daz*daz-l . OdO) 
simll  (3)— 3.0d0*si00  (3)  /a 
siOO (4) =x2ml*day*daz 
simll (4) *-3. OdO* si 00 (4) /a 
siOO (5) »x2m2*dax*day 
simll (5) — 3. 0d0*si00 (5) /a 
c  write (60, 3180) 

c3180  formatdx, '  i  siOO(i)  simll(i)') 

c  write (60, 7321)  (i,  siOO (i) ,  simll (i) ,  i-1,5) 

c  7321  format (lx, i3, dl5 . 8, 2x, dl5 . 8) 
c 

go  to  (840, 850, 7777, 860) , inttyp 
c 

820  pi 00 (1) -x22* (ak* (days-dax3) - (5 . 0d0*dak* (daxs-days) + 

#  2 . OdO* (day*dyk-dax*dxk) ) /a) 

pimll (1) »x22* (3 . OdO* (ak* (dax3-days) + (5 . 0d0*dak* (daxs- 
t  days) +2 . OdO* (day*dyk  -  dax*dxk) ) /a) /a) 

/<P 
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pill (1) «x22*dak* (daxs-days) 

piOO  (2)  -x21*  <-dax*daz*ak- (5 .  OdO*dax*daz*dak-dax*dzk 

#  -daz*dxk) /a) 

pimll (2) *x21* (3 . OdO* (ak*dax*daz+ (5 . OdO*dax*daz*dak- 

#  dax*dzk  -  daz*dxk) /a) /a) 
pill (2) «dax*daz*dak*x21 

piOO (3) *x20* <ak* (1 . OdO-3 . OdO*dazs) -3. OdO* (5. OdO* 

#  dak*dazs  -  2 . OdO*daz*dzk  -dak) /a) 

pimll (3) «x20* (3 . OdO* (ak* (3 . OdO*dazs-l . OdO) +3 . OdO* 

#  (5. OdO*dak*dazs  -  2 . OdO*daz*dzk  -  dak) /a) /a) 
pill (3)*x20* (3. OdO*dak*dazs-dak) 

piOO (4) «x2ml*  <-daz*day*ak- (5 .  OdO*day*daz*dak-day*dzk 

#  -daz*dyk) /a) 

pimll (4) -x2ml* (3 . OdO* (ak*day*daz+  <5 . OdO*day*daz*dak- 

#  day*dzk  -  daz*dyk) /a) /a) 

pill (4) »day*daz*dak*x2ml 

piOO (5) *x2m2* (-ak*dax*day- (5 . OdO*dax*day*dak-dax*dyk 

#  -day*dxk) /a) 

pimll (5) -x2m2* (3 . OdO* (ak*dax*day+ (5 . OdO*dax*day*dak- 

#  dax*dyk  -  day*dxk) /a) /a) 

pill (5) »dax*day*dak*x2m2 

c 

cpi00(l)=-  x22*  (  ak*ac*ax**2 ,dO*a  -  ak*ac*ay**2.d0*a  + 
c  #  5 . 0d0*ak*ax**2 .dO  -  5. 0d0*ak*ay**2 .dO  - 

c  #  2 .d0*ac**2 ,dO*ax*dxk  +  2 . d0*ac**2 . dO*ay*dyk  ) 

c  #  /  (  ac**3.0d0*a  ) 

c  pimll (1) -3. OdO  *x22*  (  ak*ac*ax**2 .dO*a  -  ak*ac*ay**2 .dO*a  + 

c  #  5 . 0d0*ak*ax**2 .dO  -  5. 0d0*ak*ay**2 .dO  - 

c  #  2 .d0*ac**2 .dO*ax*dxk  +  2 . d0*ac**2 . dO*ay*dyk  )  / 

c  #  (  ac**3 . 0d0*a**2 . dO  ) 

c  pill (1) -ak  *x22*  <  ax**2.d0  -  ay**2.d0  )  /  {  ac**3.0d0  ) 

c  piOO  (2)=*-  x21*  (  ak*ac*az*ax*a  +  5 .  OdO*ak*az*ax  - 

c  #  ac**2 .dO*az*dxk  -  ac**2 . dO*dzk*ax  )  / 

c  #  (  ac**3 . OdO*a  ) 

c  pimll (2) =3 . OdO  *x21*  (  ak*ac*az*ax*a  +  5 . OdO*ak*az*ax  - 

c  #  ac**2 . dO*az*dxk  -  ac**2.d0*dzk*ax  )  / 

c  #  (  ac**3.0d0*a**2.d0  ) 

cc  pill (2) =x21*ak*az*ax  /  (  ac**3.0d0  ) 

c  piOO (3) =x20* (  ak*ac**3 . OdO*a  +  3. 0d0*ak*ac**2 .dO  - 

c  #  3 . 0d0*ak*ac*az**2 .dO*a  -  15 . OdO*ak*az**2 . dO  + 

c  #  6.0d0*ac**2.d0*az*dzk  )  /  (  ac**3.0d0*a  ) 

c  pimll  (3)— x20*  3. OdO  *  (  ak*ac**3 . 0d0*a  +  3 . 0d0*ak*ac**2  .dO  - 

c  #  3. OdO*ak*ac*az**2 . dO*a  -  15. 0d0*ak*az**2.d0  + 

c  #  6.0d0*ac**2.d0*az*dzk  )  /  (  ac**3 . 0d0*a**2 . dO  ) 

cc  pill (3) *-  x2Q*ak  *  (  ac**2.d0  -  3 . 0d0*az**2 .dO  )  /  (  ac**3.0d0) 

c  pi00(4)«-  x2ml* (ak*ac*az*ay*a+5 . 0d0*ak*az*ay-ac**2 . d0*az*dyk- 

c  #  ac**2 .dO*dzk*ay  )  /  (  ac**3.0d0*a  ) 

c  pimll (4 ) -3 . OdO  *x2ml*  (  ak*ac*az*ay*a  +  5 . 0d0*ak*az*ay  - 

c  #  ac**2 . dO*az*dyk  -  ac**2 . dO*dzk*ay  )  / 

c  #  (  ac**3 . OdO* a* *2 . dO  ) 

c  pill (4) -x2ml*ak*az*ay  /  (  ac**3.0d0  ) 

c  piOO (5) »-x2m 2* (ak*ac*ax*ay*a+5 . OdO*ak*ax*ay-ac**2 . d0*ax*dyk- 

c  #  ac**2 . dO*dxk*ay  )  /  (  ac**3.0d0*a  ) 

c  pimll (5) »3 . OdO  *x2m 2*  (  ak*ac*ax*ay*a  +  5 . OdO*ak*ax*ay  - 

c  #  ac**2 .dO*ax*dyk  -  ac**2 . dO*dxk*ay  )  / 

c  #  (  ac**3.0d0*a**2.d0  ) 

c  pill (5) -x2m2*ak*ax*ay  /  (  ac**3.0d0  ) 

c 

go  to  (850, 7777, 860) , (inttyp-2) 
c 

c  d  type 
c 

c0000@00@e0000000@(?0<?@30<?e<3@<j<?e<?<3ee@<?0(?@(?@<?(aeee3e@03<?G<?<?(j0eee@e@@00e@@<a@ 

i  n 
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c  z22 
c#  diOO 
c 

830  diOO (l)-x22* (ak*al*ac**2*a**2*ax**2-ak*al*ac**2*a**2*ay**2+ 

#  10 . 0d0*ak*al*ac*a*ax**2-10 . 0d0*ak*al*ac*a*ay**2+35 . 0d0*ak* 

#  al*ax**2  -  35 .d0*ak*al*ay**2  - 

#  2 .d0*ak*ac**3*a*ax*dxl  +  2 .d0*ak*ac**3*a*ay*dyl  - 

#  10 . 0d0*ak*ac**2*ax*dxl  +  10 . 0d0*ak*ac**2*ay*dyl  - 

#  2 .d0*al*ac**3*a*ax*dxk  +  2 . d0*al*ac**3*a*ay*dyk  - 

#  10 . 0d0*al*ac**2*ax*dxk  +  10 . 0d0*al*ac**2*ay*dyk  + 

#  2 .d0*ac**4*dxk*dxl  -  2 .d0*ac**4*dyk*dyl-2 . d0*ac**3*dkl*a*ax**2  + 

#  2 . d0*ac**3*dkl*a*ay**2  -  5 . d0*ac**2*dkl*ax**2  + 

#  5 . d0*ac**2*dkl*ay**2  )  /  (  ac**4*a**2  ) 
c 

c  dimll 
c 

dimll (1)— x22* (3 . d0*ak*al*ac**2*a**2*ax**2- 

#  3 .d0*ak*al*ac**2*a**2*ay**2  +  30 . 0d0*ak*al*ac*a*ax**2  - 

#  30 . 0d0*ak*al*ac*a*ay**2  +  105 . d0*ak*al*ax**2  - 

#  105.d0*ak*al*ay**2  -  6.d0*ak*ac**3*a*ax*dxl  + 

#  6 .d0*ak*ac**3*a*ay*dyl  -  30 . 0d0*ak*ac**2*ax*dxl  + 

#  30 . OdO*ak*ac**2*ay*dyl  -  6.d0*al*ac**3*a*ax*dxk  + 

#  6 .d0*al*ac**3*a*ay*dyk  -  30 . 0d0*al*ac**2*ax*dxk  + 

#  30 . 0d0*al*ac**2*ay*dyk  -  ac**4*dkl*a**2*ax**2  + 

#  ac**4*dkl*a**2*ay**2  +  6.d0*ac**4*dxk*dxl  - 

#  6.d0*ac**4*dyk*dyl  -  6.d0*ac**3*dkl*a*ax**2  + 

#  6.d0*ac**3*dkl*a*ay**2  -  15.d0*ac**2*dkl*ax**2  + 

#  15 .d0*ac**2*dkl*ay**2  )  /  (  ac**4*a**3  ) 
c 

c  dill 
c 

dill (1) *-x22* (2 .d0*ak*al*ac*a*ax**2-2 .d0*ak*al*ac*a*ay**2+ 

#  10 . OdO*ak*al*ax**2  -  10 . 0d0*ak*al*ay**2  -  2.d0*ak*ac**2*ax*dxl  + 

#  2 . d0*ak*ac**2*ay*dyl  -  2.d0*al*ac**2*ax*dxk  + 

#  2 . d0*al*ac**2*ay*dyk  -  ac**2*dkl*ax**2  +  ac**2*dkl*ay**2  )  / 

#  (  ac**4*a  ) 
c 

c  di20 
c 

di20 (1) =x22*ak*al* (ax**2-ay**2) / <ac**4) 
c 
c 

cz21 
c  diOO 
c 

diOO (2) -x21* (ak*al*ac**2*a**2*ax*az+10 . 0d0*ak*al*ac*a*ax*az+ 

#  35.d0*ak*al*ax*az  -  ak*ac**3*a*ax*dzl  -  ak*ac**3*a*az*dxl  - 

#  5.d0*ak*ac**2*ax*dzl  -  5 . d0*ak*ac**2*az*dxl  -  al*ac**3*a*ax*dzk  - 

#  al*ac**3*a*az*dxk  -  5 .d0*al*ac**2*ax*dzk  -  5 . d0*al*ac**2*az*dxk  + 

#  ac**4*dxk*dzl  +  ac**4*dxl*dzk  -  2 . d0*ac**3*dkl*a*ax*az  - 

#  5 . d0*ac**2*dkl*ax*az  )  /  (  ac**4*a**2  ) 
c 

c  dimll 
c 

dimll (2) «-x21* (3 . d0*ak*al*ac**2*a**2*ax*az+ 

#  30 . 0d0*ak*al*ac*a*ax*az  +  105 . d0*ak*al*ax*az  - 

#  3 . d0*ak*ac**3*a*ax*dzl  -  3.d0*ak*ac**3*a*az*dxl  - 

#  15.d0*ak*ac**2*ax*dzl  -  15.d0*ak*ac**2*az*dxl  - 

#  3.d0*al*ac**3*a*ax*dzk  -  3.d0*al*ac**3*a*az*dxk  - 

#  15.d0*al*ac**2*ax*dzk  -  15 .d0*al*ac**2*az*dxk  - 

#  ac**4*dkl*a**2*ax*az  +  3 .d0*ac**4*dxk*dzl  +  3.d0*ac**4*dxl*dzk  - 

#  6 .d0*ac**3*dkl*a*ax*az  -  15 . dQ*ac**2*dkl*ax*az  )/(  ac**4*a**3  ) 
c 

c  dill 

r r? 
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dill (2)»-x21* (2.dO*ak*al*ac*a*ax*az+lO. 0d0*ak*al*ax*az- 

#  ak*ac**2*ax*dzl  -  ak*ac**2*az*dxl  -  al*ac**2*ax*dzk  - 

#  al*ac**2*az*dxk  -  ac**2*dkl*ax*az  )  /  (  ac**4*a  ) 
c 

c 

c  di20 
c 

di20 (2) »x21*ak*al*ax*az/  (ac**4) 
c 

c  d20 
c  dkOO 
c 

diOO (3) — x20* (ak*al*ac**2*a**2*ax**2+ak*al*ac**2*a**2*ay**2- 

#  2 .d0*ak*al*ac**2*a**2*az**2  +  10 . 0d0*ak*al*ac*a*ax**2  + 

#  10 . 0d0*ak*al*ac*a*ay**2  -  20 . 0d0*ak*al*ac*a*az**2  + 

#  35 . d0*ak*al*ax**2  +  35.d0*ak*al*ay**2  -  70 . 0d0*ak*al*az**2  - 

#  2 .d0*ak*ac**3*a*ax*dxl  -  2 .d0*ak*ac**3*a*ay*dyl  + 

#  4 .d0*ak*ac**3*a*az*dzl  -  10 . 0d0*ak*ac**2*ax*dxl  - 

#  10 . OdO*ak*ac**2*ay*dyl  +  20 . 0d0*ak*ac**2*az*dzl  - 

#  2.d0*al*ac**3*a*ax*dxk  -  2 .d0*al*ac**3*a*ay*dyk  + 

#  4 .d0*al*ac**3*a*az*dzk  -  10 . 0d0*al*ac**2*ax*dxk  - 

#  10 . OdO*al*ac**2*ay*dyk  +  20 . 0d0*al*ac**2*az*dzk  + 

#  2 .d0*ac**4*dxk*dxl  +  2 .d0*ac**4*dyk*dyl  -  4 . d0*ac**4*dzk*dzl  - 

#  2 .d0*ac**3*dkl*a*ax**2  -  2.d0*ac**3*dkl*a*ay**2  + 

#  4 . d0*ac**3*dkl*a*az**2  -  5 . d0*ac**2*dkl*ax**2  - 

#  5.d0*ac**2*dkl*ay**2  +  10 . OdO*ac**2*dkl*az**2  )  /  (  ac**4*a**2 
c 

c  dkmll 
c 

dimll (3) *x20* (3.d0*ak*al*ac**2*a**2*ax**2+ 

#  3 .d0*ak*al*ac**2*a**2*ay**2  -  6.d0*ak*al*ac**2*a**2*az**2  + 

#  30 . 0d0*ak*al*ac*a*ax**2  +  30 . 0d0*ak*al*ac*a*ay**2  - 

#  60 . 0d0*ak*al*ac*a*az**2  +  105 . d0*ak*al*ax**2  + 

#  105.d0*ak*al*ay**2  -  210 . 0d0*ak*al*az**2  - 

#  6 . d0*ak*ac**3*a*ax*dxl  -  6 . d0*ak*ac**3*a*ay*dyl  + 

#  12 ,d0*ak*ac**3*a*az*dzl  -  30 . 0dQ*ak*ac**2*ax*dxl  - 

#  30 . 0d0*ak*ac**2*ay*dyl  +  60 . 0d0*ak*ac**2*az*dzl  - 

#  6.d0*al*ac**3*a*ax*dxk  -  6 .d0*al*ac**3*a*ay*dyk  + 

#  12.d0*al*ac**3*a*az*dzk  -  30 . 0d0*al*ac**2*ax*dxk  - 

#  30 . 0d0*al*ac**2*ay*dyk  +  60 . Qd0*al*ac**2*az*dzk  - 

#  ac**4*dkl*a**2*ax**2  -  ac**4*dkl*a**2*ay**2  + 

#  2.d0*ac**4*dkl*a**2*az**2  +  6 . d0*ac**4*dxk*dxl  + 

#  6 .d0*ac**4*dyk*dyl  -  12 .d0*ac**4*dzk*dzl  - 

#  6 . d0*ac**3*dkl*a*ax**2  -  6.d0*ac**3*dkl*a*ay**2  + 

#  I2.d0*ac**3*dkl*a*az**2  -  15 . d0*ac**2*dkl*ax**2  - 

#  15.d0*ac**2*dkl*ay**2  +  30 . 0d0*ac**2*dkl*az**2  )  / 

#  (  ac**4*a**3  ) 
c 

c 

c#  dill 
c 

dill (3)-x20* (2.d0*ak*al*ac*a*ax**2+2.d0*ak*al*ac*a*ay**2- 

#  4.d0*ak*al*ac*a*az**2  +  10 . 0d0*ak*al*ax**2  + 

#  10 . 0d0*ak*al*ay**2  -  20 . 0d0*ak*al*az**2  - 

#  2 ,d0*ak*ac**2*ax*dxl  -  2 . d0*ak*ac**2*ay*dyl  + 

#  4.d0*ak*ac**2*az*dzl  -  2 .d0*al*ac**2*ax*dxk  - 

#  2 .d0*al*ac**2*ay*dyk  +  4 . d0*al*ac**2*az*dzk  -  ac**2*dkl*ax**2  - 

#  ac**2*dkl*ay**2  +  2 . d0*ac**2*dkl*az**2  )  /  (  ac**4*a  ) 
c 

c#  di20 
c 

di20 (3) — x20*ak*al* (ax**2+ay**2-2 .d0*az**2) /  (ac**4) 
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c  d2ml 
c#  diOO 
c 
c 

diOO (4) -x2ml* (ak*al*ac**2*a**2*az*ay+10 . OdO*ak*al*ac*a*az*ay+ 

#  35.d0*ak*al*az*ay  -  ak*ac**3*a*az*dyl  -  ak*ac**3*a*ay*dzl  - 

#  5.d0*ak*ac**2*az*dyl  -  5.d0*ak*ac**2*ay*dzl  - 

#  al*ac**3*a*az*dyk  -  al*ac**3*a*ay*dzk  -  5 .d0*al*ac**2*az*dyk  - 

#  5.d0*al*ac**2*ay*dzk  +  ac**4*dzk*dyl  +  ac**4*dzl*dyk  - 

#  2.d0*ac**3*dkl*a*az*ay  -  5.d0*ac**2*dkl*az*ay  )/(  ac**4*a**2  ) 
c 

c#  dimll 
c 

dimll  (4)— x2ml*  <3.d0*ak*al*ac**2*a**2*az*ay+ 

#  30 . OdO*ak*al*ac*a*az*ay  +  105 . dO*ak*al*az*ay  - 

#  3.d0*ak*ac**3*a*az*dyl  -  3 . d0*ak*ac**3*a*ay*dzl  - 

#  15.d0*ak*ac**2*az*dyl  -  15.d0*ak*ac**2*ay*dzl  - 

#  3 .d0*al*ac**3*a*az*dyk  -  3.d0*al*ac**3*a*ay*dzk  - 

#  15 . d0*al*ac**2*az*dyk  -  15 .d0*al*ac**2*ay*dzk  - 

#  ac**4*dkl*a**2*az*ay  +  3 .d0*ac**4*dzk*dyl  +  3 . d0*ac**4*dzl*dyk  - 

#  6*ac**3*dkl*a*az*ay  -  15 .d0*ac**2*dkl*az*ay  )  /  (  ac**4*a**3  ) 
c 

c 

c#  dill 
c 

dill (4) *- x2ml* (2 . d0*ak*al*ac*a*az*ay+10 . 0d0*ak*al*az*ay- 

#  ak*ac**2*az*dyl  -  ak*ac**2*ay*dzl  -  al*ac**2*az*dyk  - 

#  al*ac**2*ay*dzk  -  ac**2*dkl*az*ay  )  /  (  ac**4*a  ) 
c 

c#  di20 
c 

di20 (4) «x2ml*ak*al*az*ay/ (ac**4) 
c 
c 

cd2m2 
c#  diOO 
c 
c 

diOO  (5)  =*x2m2* (ak*al*ac**2*a**2*ax*ay+10 . OdO*ak*al*ac*a*ax*ay+ 

#  35.d0*ak*al*ax*ay  -  ak*ac**3*a*ax*dyl  -  ak*ac**3*a*ay*dxl  - 

#  5.d0*ak*ac**2*ax*dyl  -  5 . d0*ak*ac**2*ay*dxl  - 

#  al*ac**3*a*ax*dyk  -  al*ac**3*a*ay*dxk  -  5 . d0*al*ac**2*ax*dyk  - 

#  5 . d0*al*ac**2*ay*dxk  +  ac**4*dxk*dyl  +  ac**4*dxl*dyk  - 

#  2 . d0*ac**3*dkl*a*ax*ay  -  5 . d0*ac**2*dkl*ax*ay  )  /  (  ac**4*a**2  ) 
c 

c#  dimll 
c 

dimll  (5)— x2m2*  (3  .d0*ak*al*ac**2*a**2*ax*ay+ 

#  30 . 0d0*ak*al*ac*a*ax*ay  +  105.d0*ak*al*ax*ay  - 

#  3.d0*ak*ac**3*a*ax*dyl  -  3 . d0*ak*ac**3*a*ay*dxl  - 

#  15.d0*ak*ac**2*ax*dyl  -  15.d0*ak*ac**2*ay*dxl  - 

#  3.d0*al*ac**3*a*ax*dyk  -  3 .d0*al*ac**3*a*ay*dxk  - 

#  15.d0*al*ac**2*ax*dyk  -  15 > d0*al*ac**2*ay*dxk  - 

#  ac**4*dkl*a**2*ax*ay  +  3 .d0*ac**4*dxk*dyl  + 

#  3 . d0*ac**4*dxl*dyk  -  6.d0*ac**3*dkl*a*ax*ay  - 

#  15.d0*ac**2*dkl*ax*ay  )  /  (  ac**4*a**3  ) 
c 

c#  dill 
c 

dill (5) — x2m 2* (2 . d0*ak*al*ac*a*ax*ay+10 . 0d0*ak*al*ax*ay- 

#  ak*ac**2*ax*dyl  -  ak*ac**2*ay*dxl  -  al*ac**2*ax*dyk  - 

#  al*ac**2*ay*dxk  -  ac**2*dkl*ax*ay  )  /  (  ac**4*a  ) 
c 

c#  di20 
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c 

di20  (5)  «x2m2*a)c*al*ax*ay/  (ac**4) 
c 
c 
c 

c00@@000@00@00@@@@@@@@@0@0@@0@@9@@00@@000@@@@@@@00@@@00@0@0000@@0@@0@0@0 

c 

go  to  860 

840  sjOO (1) *x22* (dbxs-dbys) 

sjmll (l)»-3.0d0*s jOO (1) /b 
a jOO (2) *x21*dbx*dbz 
sjmll  (2)—  3.0d0*sj00(2)/b 
sjOO (3)«x20* (3 . 0d0*dbz*dbz-l . OdO ) 
sjmll  (3)  —3 . 0d0*s jOO  (3)  /b 
s  j  0  0 (4) «x2ml*dby*dbz 
sjmll  (4)—  3.0d0*sj00(4)/b 
s jOO (5) “x2m2*dbx*dby 
sjmll  (5)— 3.0d0*sj00{5)  /b 
c 

go  to  890 
c 

850  p jOO (1) =x22* (bi* (dbys-dbxs) - {5 . 0d0*dbi*  (dbxs-dbys)  + 

#  2 . OdO* (dby*dyi-dbx*dxi) ) /b) 

pjmll (1) «x22* (3 . OdO* {bi* (dbxs-dbys)  +  <5 . 0d0*dbi* (dbxs 

#  -dbys) +2 . OdO* (dby*dyi  -  dbx*dxi) ) /b) /b) 
pjll (1) =dbi* (dbxs-dbys) *x22 

pjOO (2) “x21* (-dbx*dbz*bi- (5 . 0d0*dbx*dbz*dbi-dbx*dzi 

#  -dbz*dxi)/b) 

pjmll (2) =x21*  <3 . OdO* (bi*dbx*dbz+ (5 . 0d0*dbx*dbz*dbi- 

#  dbx*dzi  -  dbz*dxi) /b) /b) 
pjll (2) «dbx*dbz*dbi*x21 

pjOO (3)-x20* (bi* (1 . OdO-3 . 0d0*dbzs) -3. OdO* (5. OdO* 

#  dbi*dbzs  -  2 . 0d0*dbz*dzi  -dbi)/b) 

pjmll (3) -x20* (3 . OdO* (bi* (3 . OdO*dbzs-l . OdO) +3. OdO* 

#  (5 . OdO*dbi*dbzs  -  2 . OdO*dbz*dzi  -  dbi)/b)/b) 
pjll (3) »x20* (3 . OdO*dbi*dbzs-dbi) 

pjOO (4) »x2ml* (-dbz*dby*bi- (5 . OdO*dby*dbz*dbi-dby*dzi 

#  -dbz*dyi)/b) 

pjmll (4) =x2ml* (3 . OdO*  <bi*dby*dbz+ (5 . OdO*dby*dbz*dbi- 

#  dby*dzi  -  dbz*dyi) /b) /b) 

pjll (4) «dby*dbz*dbi*x2ml 

pjOO (5) *x2m 2* (-bi*dbx*dby- (5 . OdO*dbx*dby*dbi-dbx*dyi 

#  -dby*dxi) /b) 

pjmll (5) =x2m2* (3 . OdO* (bi*dbx*dby+ (5 . OdO*dbx*dby*dbi- 

#  dbx*dyi  -  dby*dxi) /b) /b) 

pjll (5) «dbx*dby*dbi*x2m2 

cpj00(l)»-  x22* (  bi*bc*bx**2 ,dO*b  -  bi*bc*by**2 . dO*b  + 
c  #  5 . 0d0*bi*bx**2 .dO  -  5 . 0d0*bi*by**2 . dO  - 

c  #  2.d0*bc**2.d0*bx*dxi  +  2 . d0*bc**2 . dO*by*dyi  ) 

c  #  /  (  bc**3.0d0*b  ) 

c  p jmll (1 ) =3 . OdO  *x22*  (  bi*bc*bx**2 . d0*b  -  bi*bc*by**2 . d0*b  + 

c  #  5 . 0d0*bi*bx**2 . dO  -  5 . 0d0*bi*by**2 . dO  - 

c  #  2 .d0*bc**2 .dO*bx*dxi  +  2 . d0*bc**2 . dO*by*dyi  )  / 

c  #  (  be* *3. 0d0*b**2 . dO  ) 

c  pjll (1) «bi  *x22*  (  bx**2.d0  -  by**2.d0  )  /  (  bc**3.0d0  ) 

c  pj00{2)»-  x21*(  bi*bc*bz*bx*b  +  5 . 0d0*bi*bz*bx  - 

c  #  bc**2 .d0*bz*dxi  -  bc**2 .d0*dzi*bx  )  / 

c  #  (  bc**3 . 0d0*b  ) 

c  pjmll (2) -3. OdO  *x21*  {  bi*bc*bz*bx*b  +  5 . 0d0*bi*bz*bx  - 

c  #  bc**2 .dO*bz*dxi  -  bc**2 . dO*dzi*bx  )  / 

c  #  (  be** 3. 0d0*b**2.d0  ) 

c  pjll (2)-x21*bi*bz*bx  /  (  bc**3.0d0  ) 

c  pjOO (3)-x20* {  bi*bc**3 . OdO*b  +  3 . 0d0*bi*bc**2 .dO  - 

c  #  3.0d0*bi*bc*bz**2.d0*b  -  15 . 0d0*bi*bz**2 .dO  + 

Y 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c3256 

c 

c  8321 


6.0d0*bc**2.d0*bz*dzi  )  /  (  bc**3.0d0*b  ) 
pjmll  (3)—  x20*  3 . OdO  *  (  bi*bc**3 . OdO*b  +  3 .  OdO*bi*bc**2 .dO  - 
3. 0d0*bi*bc*bz**2 .dO*b  -  15.0d0*bi*bz**2.d0  + 
6.0d0*bc**2.d0*bz*dzi  )  /  (  bc**3.0d0*b**2.d0  ) 
pjll<3)  —  x20*bi  *  {  bc**2.d0  -  3 . 0d0*bz**2  .dO  )  /  (  bc**3.0d0  ) 
pjOO (4) — x2ml* (bi*bc*bz*by*b+5 . OdO*bi*bz*by  -  bc**2 .dO*bz*dyi  - 
bc**2.d0*dzi*by  )  /<  bc**3.0d0*b  ) 
pjmll (4) -3. OdO  *x2ml*  {  bi*bc*bz*by*b  +  5 . OdO*bi*bz*by  - 
bc**2 .dO*bz*dyi  -  bc**2 . dO*dzi*by  )  / 

(  bc**3. 0d0*b**2 .dO  ) 
p jll (4) -x2ml*bi*bz*by  /  (  bc**3.0d0  ) 

pjOO (5) «-x2m 2*  (bi*bc*bx*by*b+5 . 0d0*bi*bx*by-bc**2 .dO*bx*dyi- 
bc**2 . dO*dxi*by  )  /  (  bc**3.0d0*b  ) 
pjmll (5) -3. OdO  *x2m2*  (  bi*bc*bx*by*b  +  5 . OdO*bi*bx*by  - 
bc**2 .dO*bx*dyi  -  bc**2 .dO*dxi*by  )  / 

(  bc**3 . 0d0*b**2 .dO  ) 
p jll (5) =x2m2*bi*bx*by  /  (  bc**3.0d0  ) 

write (60, 3256) 

format(lx,'  i  pjOO(i)  pjmll(i)  pjll(i)') 

write (60, 8321)  (i,pj00  <i)  ,  pjmll (i) ,pjll (i) ,  i-1, 5) 
format (lx, i3,dl5 . 8, 2x, dl5 . 8, 2x, dl5 . 8 ) 


c 

go  to  890 
c 

c  d  type  integrals 
c 

c00000000@0@@@00@0@0@@@@@30@@@3@00@00@0@@3@@00@@@03000030@00  999999999999 


c 

c 

c 

c# 


z22 

diOO 


860  djOO (l)-x22* (bi*b j*bc**2*b**2*bx**2-bi*b j*bc**2*b**2*by**2+ 

#  10 . OdO*bi*b j*bc*b*bx**2-10 . OdO*bi*bj*bc*b*by**2+35 . OdO*bi* 

#  b j*bx**2  -  35.d0*bi*bj*by**2  - 

#  2.d0*bi*bc**3*b*bx*dx j  +  2.d0*bi*bc**3*b*by*dyj  - 

#  10 . 0d0*bi*bc**2*bx*dx j  +  10 . OdO*bi*bc**2*by*dy j  - 

#  2 .d0*bj*bc**3*b*bx*dxi  +  2 . dO*b j*bc**3*b*by*dyi  - 

#  10 . 0d0*b j*bc**2*bx*dxi  +  10. 0d0*bj*bc**2*by*dyi  + 

#  2 . dO*bc*M*dxi*dx j  -  2.d0*bc**4*dyi*dyj-2.d0*bc**3*di j*b*bx**2  + 

#  2 . d0*bc**3*di j*b*by**2  -  5 .d0*bc**2*di j*bx**2  + 

#  5.d0*bc**2*di j*by**2  )  /  (  bc**4*b**2 .) 
c 

c#  dimll 
c 

djmll (1) — x22* (3 . d0*bi*b j*bc**2*b**2*bx**2- 

#  3.d0*bi*bj*bc**2*b**2*by**2  +  30 . 0d0*bi*bj*bc*b*bx**2  - 

#  30. 0d0*bi*b j*bc*b*by**2  +  105.d0*bi*bj*bx**2  - 

#  105.d0*bi*bj*by**2  -  6 . d0*bi*bc**3*b*bx*dx j  + 

#  6 ,d0*bi*bc**3*b*by*dy j  -  30 . OdO*bi*bc**2*bx*dx j  + 

#  30 . 0d0*bi*bc**2*by*dy j  -  6 . d0*b j*bc**3*b*bx*dxi  + 

#  6.d0*bj*bc**3*b*by*dyi  -  30 . OdO*bj*bc**2*bx*dxi  + 

#  30 . 0d0*b j*bc**2*by*dyi  -  bc**4*di j*b**2*bx**2  + 

#  bc**4*dij*b**2*by**2  +  6.d0*bc**4*dxi*dxj  - 

#  6.d0*bc**4*dyi*dy j  -  6 .d0*bc**3*di j*b*bx**2  + 

#  6.d0*bc**3*di j*b*by**2  -  15.d0*bc**2*di j*bx**2  + 

#  15.d0*bc**2*dij*by**2  )  /  (  bc**4*b**3  ) 
c 

c#  dill 
c 

djll (1)— x22* <2.d0*bi*bj*bc*b*bx**2-2.d0*bi*bj*bc*b*by**2+ 

#  10 . 0d0*bi*b j*bx**2  -  10 . 0d0*bi*b j*by**2  -  2 ,d0*bi*bc**2*bx*dx j  + 

#  2 .d0*bi*bc**2*by*dy j  -  2 .d0*b j*bc**2*bx*dxi  + 

ty 
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#  2.d0*bj*bc**2*by*dyi  -  bc**2*di j*bx**2  +  bc**2*di j*by**2  )  / 

#  (  bc**4*b  ) 
c 

c#  di20 
c 

dj20 (1) -x22*bi*bj* (bx**2-by**2) / (bc**4) 
c 
c 

cz21 
c#  diOO 
c 

djOO (2) «x21* (bi*b j*bc**2*b**2*bx*bz+10 . OdO*bi*b j*bc*b*bx*bz+ 

#  35 .dO*bi*b j*bx*bz  -  bi*bc**3*b*bx*dz j  -  bi*bc**3*b*bz*dx j  - 

#  5.d0*bi*bc**2*bx*dz j  -  5.d0*bi*bc**2*bz*dx j  -  b j*bc**3*b*bx*dzi  - 

#  b j*bc**3*b*bz*dxi  -  5.d0*bj*bc**2*bx*dzi  -  5.d0*bj*bc**2*bz*dxi  + 

#  bc**4*dxi*dz j  +  bc**4*dx j*dzi  -  2 ,d0*bc**3*di j*b*bx*bz  - 

#  5.d0*bc**2*di j*bx*bz  )  /  (  bc**4*b**2  ) 
c 

c#  dimll 
c 

djmll (2)«-x21* (3.d0*bi*bj*bc**2*b**2*bx*bz+ 

#  30 . 0d0*bi*b j*bc*b*bx*bz  +  105 . d0*bi*b j*bx*bz  - 

#  3 . d0*bi*bc**3*b*bx*dz j  -  3 .d0*bi*bc**3*b*bz*dx j  - 

#  15 .d0*bi*bc**2*bx*dz j  -  15.d0*bi*bc**2*bz*dxj  - 

#  3 .d0*b j*bc**3*b*bx*dzi  -  3 .d0*bj*bc**3*b*bz*dxi  - 

#  15 . d0*b j*bc**2*bx*dzi  -  lS.d0*bj*bc**2*bz*dxi  - 

#  bc**4*di j*b**2*bx*bz  +  3 . d0*bc**4*dxi*dz j  +  3.d0*bc**4*dxj*dzi  - 

#  6.d0*bc**3*di j*b*bx*bz  -  15.d0*bc**2*di j*bx*bz  )/(  bc**4*b**3  ) 

c 

c#  dill 
c 

djll (2) »-x2l* (2 . d0*bi*b j*bc*b*bx*bz+10 . 0d0*bi*b j*bx*bz- 

#  bi*bc**2*bx*dz j  -  bi*bc**2*bz*dx j  -  b j*bc**2*bx*dzi  - 

#  b j*bc**2*bz*dxi  -  bc**2*di j*bx*bz  )  /  (  bc**4*b  ) 
c 

c 

c#  di20 
c 

dj20 (2) -x21*bi*bj*bx*bz/ (bc**4) 
c 

c  d20 
c  diOO 
c 

djOO (3)«-x20* (bi*b j*bc*  *2*b**2*bx**2+bi*b j*bc**2*b**2*by**2- 

#  2.d0*bi*bj*bc**2*b**2*bz**2  +  10 . 0d0*bi*b j*bc*b*bx**2  + 

#  10 . 0d0*bi*bj*bc*b*by**2  -  20 . 0d0*bi*bj*bc*b*bz**2  + 

#  35.d0*bi*bj*bx**2  +  35.d0*bi*bj*by**2  -  70 . 0d0*bi*b j*bz**2  - 

#  2 .d0*bi*bc**3*b*bx*dx j  -  2 .d0*bi*bc**3*b*by*dy j  + 

#  4 .d0*bi*bc**3*b*bz*dz j  -  10 . 0d0*bi*bc**2*bx*dx j  - 

#  10 . 0d0*bi*bc**2*by*dy j  +  20 . 0d0*bi*bc**2*bz*dz j  - 

#  2 .d0*b j*bc**3*b*bx*dxi  -  2.d0*bj*bc**3*b*by*dyi  + 

#  4 ,d0*b j*bc**3*b*bz*dzi  -  10. 0d0*bj*bc**2*bx*dxi  - 

#  10 . 0d0*b j*bc**2*by*dyi  +  20 . 0d0»bj*bc**2*bz*dzi  + 

#  2 .d0*bc**4*dxi*dx j  +  2 .d0*bc**4*dyi*dyj  -  4 . d0*bc**4*dzi*dz j  - 

#  2 .d0*bc**3*di j*b*bx**2  -  2 ,d0*bc**3*di j*b*by**2  + 

#  4 . d0*bc**3*di j*b*bz**2  -  5.d0*bc**2*di j*bx**2  - 

#  5 .  d0*bc**2*di j*by**2  +  10 . 0d0*bc*y'2*di  j*bz**2  )  /  (  bc**4*b**2  ) 
c 

c  dimll 
c 

djmll  (3) «x20* (3.d0*bi*bj*bc**2*b**2*bx**2+ 

#  3.d0*bi*bj*bc**2*b**2*by**2  -  6.d0*bi*bj*bc**2*b**2*bz**2  + 

#  30 . 0d0*bi*b j*bc*b*bx**2  +  30 . 0d0*bi*bj*bc*b*by**2  - 

#  €0 . 0d0*bi*b j*bc*b*bz**2  +  105 . d0*bi*b j*bx**2  + 
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#  105.d0*bi*bj*by**2  -  210 . 0d0*bi*b j*bz**2  - 

#  6.d0*bi*bc**3*b*bx*dxj  -  6.d0*bi*bc**3*b*by*dyj  + 

#  12 .d0*bi*bc**3*b*bz*dz j  -  30. 0d0*bi*bc**2*bx*dxj  - 

#  30. 0d0*bi*bc**2*by*dyj  +  60 . 0d0*bi*bc**2*bz*dz j  - 

#  6.d0*bj*bc**3*b*bx*dxi  -  6.d0*b j*bc**3*b*by*dyi  + 

#  12 . d0*b j*bc**3*b*bz*dzi  -  30 . 0d0*b j*bc**2*bx*dxi  - 

#  30 . 0d0*bj*bc**2*by*dyi  +  60 . 0d0*b j*bc**2*bz*dzi  - 

#  bc*M*dij*b**2*bx**2  -  bc**4*di j*b**2*by**2  + 

#  2 . d0*bc**4*di j*b**2*bz**2  +  6 . d0*bc**4*dxi*dx j  + 

#  6.d0*bc**4*dyi*dyj  -  12 ,d0*bc**4*dzi*dz j  - 

#  6 .d0*bc**3*di j*b*bx**2  -  6 . d0*bc**3*di j*b*by**2  + 

#  I2.d0*bc**3*dij*b*bz**2  -  15 . d0*bc**2*di j*bx**2  - 

#  15.d0*bc**2*di  j*by**2  +  30 . 0d0*bc**2*di  j*bz**2  )  / 

#  (  bc**4*b**3  ) 
c 

c 

c#  dill 
c 

djll (3) -x20* (2 .d0*bi*bj*bc*b*bx**2+2 .d0*bi*bj*bc*b*by**2- 

#  4 .d0*bi*b j*bc*b*bz**2  + -10. 0d0*bi*bj*bx**2  + 

#  10 . 0d0*bi*b j*by**2  -  20 . 0d0*bi*b j*bz**2  - 

#  2 .d0*bi*bc**2*bx*dx j  -  2 .d0*bi*bc**2*by*dy j  + 

#  4 .d0*bi*bc**2*bz*dz j  -  2 .d0*bj*bc**2*bx*dxi  - 

#  2 .d0*bj*bc**2*by*dyi  +  4 .d0*bj*bc**2*bz*dzi  -  bc**2*di j*bx**2  - 

#  bc**2*di j*by**2  +  2 . dO*Lc**2*di j*bz**2  )  /  (  bc**4*b  ) 
c 

c#  di20 
c 

dj20(3)°-x20*bi*bj* <bx**2+by**2-2 . d0*bz**2) / (bc**4) 
c 

c  d2ml 
c#  diOO 
c 
c 

djOO (4 ) =x2ml* (bi*b j*bc**2*b**2*bz*by+10 . 0d0*bi*b j*bc*b*bz*by+ 

#  35 . d0*bi*b j*bz*by  -  bi»bc**3*b*bz*dy j  -  bi*bc**3*b*by*dz j  - 

#  5.d0*bi*bc**2*bz*dyj  -  5 . d0*bi*bc**2*by*dz j  - 

#  b j*bc**3*b*bz*dyi  -  bj*bc**3*b*by*dzi  -  5.d0*bj*bc**2*bz*dyi  - 

#  5 .d0*bj*bc**2*by*dzi  +  bc**4*dzi*dy j  +  bc**4*dz j*dyi  - 

#  2 ,d0*bc**3*di j*b*bz*by  -  5 . d0*bc**2*di j*bz*by  )/{  bc**4*b**2  ) 
c 

c#  dimll 
c 

djmll (4) =-x2ml* (3.d0*bi*bj*bc**2*b**2*bz*by+ 

#  30 . 0d0*bi*b j*bc*b*bz*by  +  105 . d0*bi*b j*bz*by  - 

#  3 .d0*bi*bc**3*b*bz*dy j  -  3 . d0*bi*bc**3*b*by*dz j  - 

#  15.d0*bi*bc**2*bz*dy j  -  15 . d0*bi*bc**2*by*dz j  - 

#  3.d0*bj*bc**3*b*bz*dyi  -  3 . d0*b j*bc**3*b*by*dzi  - 

#  15.d0*b j*bc**2*bz*dyi  -  15 . d0*b j*bc**2*by*dzi  - 

#  bc**4*di j*b**2*bz*by  +  3.d0*bc**4*dzi*dyj  +  3.d0*bc**4*dz j*dyi 

#  6*bc**3*di j*b*bz*by  -  15 .d0*bc**2*di j*bz*by  )  /  (  bc**4*b**3  ) 
c 

c 

c#  dill 
c 

djll (4) «-x2ml* (2.d0*bi*bj*bc*b*bz*by+10. 0d0*bi*b j*bz*by- 

#  bi*bc**2*bz*dy j  -  bi*bc**2*by*dz j  -  bj*bc**2*bz*dyi  - 

#  bj*bc**2*by*dzi  -  bc**2*di j*bz*by  )  /  (  bc**4*b  ) 
c 

c#  di20 
c 

dj20 (4) -x2ml*bi*bj*bz*by/ (bc**4) 

' 10  j 


c 

c 
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cd2m2 
c#  diOO 
c 
c 

djOO (5) -x2m2* <bi*b j*bc**2*b**2*bx*by+10 . OdO*bi*b j*bc*b*bx*by+ 

#  35.d0*bi*bj*bx*by  -  bi*bc**3*b*bx*dy j  -  bi*bc**3*b*by*dx j  - 

#  5.d0*bi*bc**2*bx*dyj  -  5.d0*bi*bc**2*by*dxj  - 

#  b j*bc**3*b*bx*dyi  -  b j*bc**3*b*by*dxi  -  5.d0*bj*bc**2*bx*dyi  - 

#  5.d0*bj*bc**2*by*dxi  +  bc**4*dxi*dy j  +  bc**4*dx j*dyi  - 

#  2 ,d0*bc**3*di j*b*bx*by  -  5 .d0*bc**2*di j*bx*by  )  /  (  bc**4*b**2  ) 
c 

c#  dimll 

c 

djmll  (5)—  x2m2*  (3 .dO*bi*b j*bc**2*b**2*bx*by+ 

#  30 . 0d0*bi*b j*bc*b*bx*by  +  105.d0*bi*bj*bx*by  - 

#  3 .d0*bi*bc**3*b*bx*dy j  -  3 . d0*bi*bc**3*b*by*dx j  - 

#  15.d0*bi*bc**2*bx*dy j  -  15 .d0*bi*bc**2*by*dx j  - 

#  3.d0*bj*bc**3*b*bx*dyi  -  3 . d0*b j*bc**3*b*by*dxi  - 

#  15.d0*bj*bc**2*bx*dyi  -  15 . d0*b j*bc**2*by*dxi  - 

#  bc**4*di j*b**2*bx*by  +  3.d0*bc**4*dxi*dyj  + 

#  3.d0*bc**4*dxj*dyi  -  6 . d0*bc**3*di j*b*bx*by  - 

#  15.d0*bc**2*di j*bx*by  )  /  (  bc**4*b**3  ) 
c 

c#  dill 
c 

djll (5)  =*-x2m2* (2 .d0*bi*b j*bc*b*bx*by+10 . 0d0*bi*b j*bx*by- 

#  bi *bc**2*bx*dy j  -  bi*bc**2*by*dx j  -  bj*bc**2*bx*dyi  - 

#  b j*bc**2*by*dxi  -  bc**2*di j*bx*by  )  /  (  bc**4*b  ) 

c 

c#  di20 
c 

dj20 (5) =x2m2*bi*b j*bx*by/ (be** 4) 

c 

c 

c@@@@0@00g0000@@@0@@@6@0e@g00@@@0@@@@@(?0@068@00@000@e0@@@@0@@000@e0@@@0@ 

c 

890  goto  (870, 872, 874, 876, 878, 880) ,inttyp 
c 

c  s-d-s 
c 

870  c000=(si00(l)*sj00(l)+si00(2)*sj00(2)+si00(3)*sj00{3)+ 

#  3i00 (4) *s jOO  (4)  +  siOO  (5) *s jOO  (5) ) 
cmlOl* (siOO (1) *3jmll (l)+si00 (2) *s jmll (2)  + 

#  siOO (3) *s jmll (3)+si00 (4) *s jmll (4)+si00 (5) *s jmll (5) ) 
cmllO- (simll (l)*sj00(l) +simll (2)*sj00(2)+ 

#  simll (3)  *3 jOO (3) +simll (4) *sj00 (4)+simll (5) *sj00(5) ) 
cm211- (simll (1) *3 jmll (1) +simll (2) *s jmll (2)+ 

#  simll (3) *s jmll (3) +simll (4 ) *s jmll (4) +simll (5) *s jmll (5) ) 
go  to  882 

c 

c  s-d-p 
c 

872  cOOO-(siOOd)  *pj00  (l)+si00  (2)  *pj00  (2)+si00  (3)*pj00  (3)  + 

#  siOO (4) *pj00 (4)  +  si00(5)*pj00(5) ) 
cmllO- (simll (1) *pj00 (1) +simll (2) *pj00 (2) + 

#  simll (3) *pj00 (3) +simll (4) *pj00 (4) +simll (5) *pj00 (5) ) 
cml01“ (siOO (1) *p jmll (l)+si00 (2) *pjmll (2)+si00 (3) *pjmll (3)+ 

#  siOO (4) *pjmll (4)  +  siOO (5) *p jmll (5) ) 
cm211- (simll (1) *pjmll (l)+simll (2)*pjmll (2)+ 

#  simll (3) *p jmll (3)+simll (4) *pjmll (4)  +simll (5) *pjmll (5) ) 
clOl-  (siOO (1) *pjll (1) +si00 (2) *p jll (2)+si00 (3) *pjll (3)+ 

#  siOO (4) *p jll (4)  +  siOO (5)*pjll (5) ) 
cOll-  (simll (1) *pjll (1) +simll (2) *pjll (2)+ 

#  simll (3) *pjll (3) +simll (4) *pjll (4)+simll (5) *pjll (5) ) 
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c 

C7182 

c 

c 

C  P 

c 

874 


875 
c 

C  3 
C 

876 


877 
c 

c  p 
c 

878 


879 
c 

c  d 
c 

880 


write (60, 7182)  pj00(l),p jmll (1) ,pjll (1) 
format (lx, '  pjOO (1) ,dl5 . 8, '  p jmll (1 ) , dl5 . 
#  '  p jll (1) ,dl5 . 8) 

go  to  882 

-d-p 

do  875iml,5 

cOOO  «c000+pi00 (i) *pj00 (i) 
cmlOl-cmlOl+piOO (i) *pjmll (i) 
clOl  *cl01+pi00 (i) *pjll (i) 
cmllO-cmllO+pimll (i) *pj00 (i) 
cm211«cm2U+pimll (i) *pjmll (i) 
cOll  «c011+pimll (i) *pjll (i) 
cllO  -cllO+pill (i) *pj00 (i) 
cOll  «c011+pill (i) *pjmll (i) 
c211  -c211+pill (i) *pjll (i) 
continue 
go  to  882 

-d-d 

do  877i«l,5 

cOOO  -cOOO+siOO (i) *dj00 (i) 
cmllO=*cmllO+simll  (i)  *dj00  (i) 
cmlOl-cmlOl+aiOO (i) *djmll (i) 
cm211»cm211+simll  (i) *djmll (i) 
clOl  -cl01+si00(i)*djll(i) 
cOll  -cOll+simll (i) *djll (i) 
c200  -c200+si00 (i) *dj20 (i) 
cllO  -cll0+3imll (i) *dj20 (i) 
continue 
go  to  882 

d-d 

do  879i*l,5 

cOOO  -cOOO+piOO  (i) *dj00  (i) 

cmlOl-cmlOl+piOO  (i) *djmll (i) 

clOl  -clOl+piOO (i) *djll (i) 

c200  -c200+pi00 (i) *dj20 (i) 

cmllO-cmllO+pimll (i) *dj00 (i) 

cm211*cm211+pimll (i) *djmll (i) 

cOll  -cOll+pimll (i) *djll (i) +pill (i) *p jmll (i) 

cllO  -cllO+pimll (i) *dj20 (i) +pill (i) *dj00 (i) 

c211  »c211+pill (i> *djll (i) 

c310  -c310+pill (i) *dj20 (i) 

continue 

go  to  882 


d-d 


do  881i*l,5 

cOOO  -cOOO+diOO (i) *dj00 (i) 

cmlOl-cmlOl+diOO (i) *djmll (i) 

clOl  -clOl+diOO (i) *djll (i) +di20 (i) *djmll (i) 

c200  -c200+di00 (i) *dj20 (i)+di20 (i) *dj00 (i) 

cmllO-cmllO+dimll (i) *dj00 (i) 

cm211-cm211+dimll (i) *djmll (i) 

cOll  -cOll+dimll (i) *djll <i ) +dill (i) *djmll (i) 

cllO  -cllO+dimll (i) *dj20 (i) +dill (i) *dj00 (i) 

c211  -c211+dill (i) *djll (i) 

c310  -c310+dill (i)*dj20(i) 

c301  -c301+di20(i)*djll(i) 

io~y 
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c400  «c400+di20 <i) *dj20 (i) 

881  continue 
c 

c 

882  call  vbcad(xcab) 
c 

cc 

c  tests  to  determine  magnitude  of  ddmx 
c 

if (xcab.eq. 0 . OdO) got ol 950 

if (dabs ( (xcab-testcab) /xcab) . gt . 1 . 0e-12 . and. 

1  buftest . It . ddtest >  ddtest-buf test 
c  write (60, 66642) xcab 

c66642  format (lx,'  xcab  after  <d|d>  ',dl5.9) 

1950  return 

4  write (60, 1000) jtyp 
1000  format(lhl,'  ***  jtyp  =',i3) 

7777  write(60, 1111) 

1111  format (lx,'  out  of  range  see  vbca  d  operators') 
stop 
end 

subroutine  vbca3(xcab) 
c  version  #2  jan  10  1985  c. woodward 

c  this  subroutine  evaluates  the  terms  <i!lxl!j>,  1=0, 

c  where  i,  j  and  the  projection  operator  1  are  on  different 

c  centers,  the  angular  integrals  are  organized  by  powers  of 

c  r  and  products  of  spherical  bessel  functions,  the  appropriate 

c  constants  to  each  term  being  provided  by  vbca.  the  radial 

c  integrals  are  then  evaluated  in  the  double  precision  functions 

c  joo,  jol ,  jlo,  joo. 

implicit  double  precision (a-h, j, o-z) 

common/cnlll2/cm211, cmllO, cmlOl, cOOO,  c011,cl01,cll0,c200,c211, 

#  c301,c310,c400,c411,xi j, aht,bht,d, inttyp, ldstr, ldstp 
parameter (npst=20, npmx=200) 

common/int2/nlp (npmx) , clp (npmx) , zip (npmx) 

common/ jprm/srzi,  ah,  bh,  dl 

dl=d 

do  100k=ldstr, ldstp 
zet3=zlp (k) +xi j 
n=nlp (k) -2 
srz=d3qrt (zet3) 

3rzi=l . OdO/srz 
ah=  aht*srzi 
bh=  bht*srzi 
ap«2 . 0d0*aht*srzi 
bp=2 . 0d0*bht*srzi 
z=ap*bp/2 . OdO 
ab2=  ah*ah+bh*bh 
c 

ck=clp(k) 

go  to  (11, 12, 13, 14, 15, 16) , inttyp 

11  xdum- joo (2+n) *ck 
xcab=xcab+xdum 
go  to  100 

12  xcab=xcab+ (joo(2+n)*c000+jol(n+3)*cl01)*ck 
go  to  100 

13  xcab=xcab+ck* (joo(n+2)*c000+(jol(n+3)*cl01+jlo(n+3)* 

#  cllO+jll <n+4) *c211) ) 
go  to  100 

14  xcab-xcab+ck* (joo(n+2)*c000+jol(n+3)*cl01+joo(n+4)*c200) 
go  to  100 

15  xcab=xcab+ck* (joo (n+2) *c000+ jol (n+3) *cl01+jlo (n+3) *cll0+ 

#  joo (n+4) *c200+ jll (n+4) *c211+ jlo (n+5) *c310) 
go  to  100 
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16  xcab-xcab+ck* ( joo (n+2) *c000+ jol (n+3) *cl01+jlo(n+3)*cll0+ 

#  joo (n+4 ) *c200+ jll (n+4) *c211+ jlo (n+5) *c310+c301* jol (n+5) 

#  +  joo (n+6) *c400) 

100  continue 

return 

end 

subroutine  vbcap(xcab) 
c  version  #2  jan  10  1985  c. woodward 

c  this  subroutine  evaluates  the  terms  <i!l><l!j>,  1-1, 

c  where  i,  j  and  the  projection  operator  1  are  on  different 

c  centers,  the  angular  integrals  are  organized  by  powers  of 

c  r  and  products  of  spherical  bessel  functions,  the  appropriate 

c  constants  to  each  term  being  provided  by  vbca.  the  radial 

c  integrals  are  then  evaluated  in  the  double  precision  functions 

c  joo,  jol,  jlo,  joo. 

implicit  double  precision (a-h, j, o-z) 

common/cnlll2/cm211, cmllO, cmlOl , cOOO, cull, cl 01, cl 10, c2 00, c2 11, 

#  c301,c310,c400,c411, xi j, aht, bht , d, inttyp, ldstr, ldstp 
parameter (npst-20, npmx=200) 

common/int2/nlp (npmx) , clp (npmx) , zip (npmx) 

common ' jprm/srzi,ah,bh,dl 

dl-d 

do  100k=ldstr, ldstp 
zet3=zlp(k) +xi  j 
n=nlp (k) -2 
srz-dsqrt (zet3) 
srzi-l . 0d0/3rz 
ah=aht*srzi 
bh=bht*srzi 
z=2 . 0d0*ah*bh 
ab2=ah*ah+bh*bh 
c 

ck=clp (k) *3 . OdO 

go  to  (11, 12, 13, 14 , 15, 16) , inttyp 

11  xcab-xcab+ck* jll (n+2) *c011 
go  to  100 

12  xcab-xcab+ck* (cOll* jll (n+2) +cll0* jlo  (n+3) ) 
go  to  100 

13  xcab-xcab+ck* (c011*jll (n+2)+cll0*jlo(n+3)+cl01*jol (n+3)+ 

#  c200* joo (n+4) ) 
go  to  100 

14  xcab=xcab+ck* (c011*jll (n+2) +c!10* jlo (n+3) +c211* jll (n+4) ) 
go  to  100 

15  xcab-xcab+ck* (c011*jll (n+2) +cll0*jlo(n+3)+cl01*jol (n+3)+ 

#  joo(n+4)*c200+jll(n+4)*c211+jol(n+5)*c301) 
go  to  100 

16  xcab-xcab+ck* (c011*jll (n+2)+cll0*jlo(n+3)+cl01*jol  (n+3)  + 

#  joo (n+4)*c200+jll(n+4)*c211+jol(n+5)*c301+jlo (n+5) *c310 

#  +c411* jll (n+6) ) 
c 

100  continue 
return 
end 

subroutine  vbcad(xcab) 
c  version  #2  jan  10  1985  c. woodward 

c  this  subroutine  evaluates  the  terms  <i!lxl!j>,  1=2, 

c  where  i,  j  and  the  projection  operator  1  are  on  different 

c  centers.  the  angular  integrals  are  organized  by  powers  of 

c  r  and  products  of  spherical  bessel  functions,  the  appropriate 

c  constants  to  each  term  being  provided  by  vbca.  the  radial 

c  integrals  are  then  evaluated  in  the  double  precision  functions 

c  joo,  jol,  jlo,  joo. 

implicit  double  precision (a-h, j, o-z) 

common/cnlll2/cm211, cmllO, cmlOl, c000,c011,cl01,cll0,c200,c211. 


n  ti  S 
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#  c301, c310, c400, c411, xi j, aht,  bht, d, inttyp, ldstr, ldstp 
parameter (npst-20, npmx=200) 

common/int2/nlp (npmx) , clp (npmx) , zip (npmx) 

common/ jprm/srzi, ah, bh,  dl 

dl-d 

do  100k=idstr, ldstp 
zet3=zlp(k) +xi j 
n=nlp (k) 
nl-n+1 

srz=dsqrt (zet3) 
srzi-l . OdO/srz 
ah-aht*srzi 
bh=bht*srzi 
z=2.0d0*ah*bh 
ab2=ah*ah+bh*bh 
c 

ck=clp (k) 

go  to  (11, 12, 13, 14, 15, 16) , inttyp 
11  xcab=xcab+ck* (c000*joo(n) +cml01*  jol (n-1 ) +cmllO*  jlo (n-1 ) 

#  +cm211* jll (n-2) )  * 
go  to  100 

12  xcab  =xcab+ck* (cOOO* joo (n) +cml01* jol (n-l)+cmll0* jlo (n-1) 

#  +cm211* jll (n-2) +C101* jol (n+1) +c011* jll (n) ) 
go  to  100 

13  xcab=xcab+ck* (cOOO* joo (n) +cml01* jol (n-1) +cl01* jol (n+1) 

#  +cmll0*  jlo (n-1 ) +cm211*  jll (n-2) +c0ll* jll (n)+cll0* 

#  jlo (n+1) +c211* jll (n+2) ) 
go  to  100 

14  xcab  =xcab+ck* (cOOO* joo (n) +cml01* jol (n-1) +cmll0* jlo (n-1) 

#  +cm211* jll (n-2) +cl01* jol (n+1) +c011* jll (n)+c200* 

#  joo (n+2) +cll0* jlo (n+1) ) 
go  to  100 

15  xcab  =xcab+ck* (cOOO* joo (n) +cml01* jol (n-1) +cl01* jol (n+1) + 

#  c2 00*  joo (n+2) +cmll0*  jlo (n-1) +cm211* jll (n-2) +c011* 

#  jll (n)+cll0* jlo (n+1) +c211* jll (n+2 ) +c310* jlo (n+3) ) 
go  to  100 

16  xcab  =xcab+ck* (cOOO* joo (n) +cml01* jol (n-l)+cl01* jol (n+l)+ 

#  c200* joo (n+2) +cmll0* jlo (n-1) +cm211* jll (n-2)+c0ll* 

#  jll (n)+cll0* jlo(n+l)+c211* jll (n+2 ) +c310* jlo (n+3) + 

#  c301* jol (n+3) +c400* joo (n+4) ) 

100  continue 

return 

end 

double  precision  function  joo(n) 
c  version  #2  jan  10  1985  c. woodward 

c  this  function  evaluates  integrals  stemming  from  a  three  center 
c  integrand.  the  integrand  includes  two  modified  spherical  bessel 
c  functions  of  the  first  kind  (1=0)  with  different  arguements,  a 
c  gaussian  and  r**n. 

implicit  double  precision (a-h, j , o-z) 
integern 

common/ jprm/srzi, ah, bh,d 
data  srpi8/0 . 22 1556731 3632 5d0/ 
iswap»0 
nl=  n  +1 
c 

c  go  to  special  functions  if  n  <  11  +  12  +  2 
c 

if  (n  . It . 2) gotoSOO 
c 

ap=2 . 0d0*ah 
bp«2.0d0*bh 
ab-ap*bp 
aps=  ap*ap 


lop*3 . sub 


Fri  Apr  5  11:22:53  1991 


129 


bps-  bp*bp 

ab2«  ah*ah+bh*bh 

abh-ap*bp/2 . OdO 

goto  (10,30,50,70) , (n/2) 

go  to  999 


if (abh.gt . 18 . OdO) gotol5 
ck«srpi8*exp (ab2+d) * (srzi**nl ) 
joo-ck*4 . 0d0*dsinh (abh) /ab 
return 

ck=srpi8* (srzi**nl) 

joo-ck*2 . 0d0*exp (ab2+d+abh) /ab 

return 


if (abh.gt . 18 . OdO) goto35 
ck-srpi8*exp (ab2+d) * (srzi**nl) 
if  (abh.gt. 0 . 3d0) goto31 
joo=ck*dcosh (abh) * (aps+bps+6 . 0d0+ 

#  (aps+bps+2 . OdO) *tanh3 (abh) ) /2 . OdO 
return 

joo=ck* (dcosh (abh) *2 . 0d0*ab+ (aps+bps+2 . OdO) * 

#  d3inh (abh) ) /ab 
return 

ck=srpi8*srzi**nl 

joo=ck*exp (ab2+d+abh) *  ( (aps+bps) 12 . 0d0+ab+l . OdO) /ab 
return 


if  (abh.gt . 18 . 0d0)goto55 
ck-srpi8*exp (ab2+d) * (srzi**nl) 
if  (abh.lt . 0 . 3d0) goto51 
joo=ck* (dcosh (abh) *2 . 0d0*ah* 

#  (3 . 0d0*bh+2 . 0d0*bh* (ah*ah+bh*bh) )  + 

#  dsinh (abh) * (ah*ah* (6. 0d0*bh*bh+ah*ah+3 . OdO)  + 

#  bh*bh* (3 . 0d0+bh*bh) +0 . 75d0) ) / (ah*bh) 
return 

joo»ck*dcosh (abh) * (ah*bh* 

#  (2 . 0d0*ah*ah*  (5 . OdO+6. 0d0*bh*bh+ah*ah) +7 . 5d0+ 

#  2 . 0d0*bh*bh* (5 . 0d0+bh*bh) ) +tanh3 (abh) *2 . 0d0*ah*bh* 

#  (ah*ah* (6 . 0d0*bh*bh+ah*ah+3 . OdO) +bh*bh* (3. 0d0+bh*bh) 

#  +  0 . 75d0) ) / (ah*bh) 
return 

ck-srpi8*srzi**nl 
apbs- (ah+bh) **2 . OdO 

joo=ck*exp (ab2+d+abh) * (apbs* (apbs+3 . OdO) +. 75d0) /abh 
return 


if (abh.gt . 18 . OdO) goto75 
ck-srpi8*exp (ab2+d) * (srzi**nl) 
if  (abh. It . 0 . 3d0) goto71 

joo-ck* (dcosh (abh) *ap*bp* (aps* (60 . 0d0+10 . 0d0*bps+3 . 0d0*aps) + 
1  bps* (60 . OdO+3 . 0d0*bps) +180 . OdO) +dsinh (abh) * (aps* (180 . 0d0+ 

1  bps*  (180.0dCH5.0d0*bps)+aps*  (30 .  OdO+15. 0d0*bps+aps) )  + 

1  bps* (180 . OdO+bps* (30 . OdO+bps) ) +120) /2 . OdO) / (8 . 0d0*ab) 
return 

joo-ck*dcosh (abh) * ( 

1  aps* (420 .d0+bps* (220.d0+15.0d0*bps)+ 
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1  aps* (42 ,d0+15. 0d0*bps+aps) ) + 

1  bps* (420.d0+bps* (42.0d0+bps) )+840.0d0+ 

1  tanh3  (abh) * (aps* (180 .dO+bps* (180 . OdO+15. 0d0*bps)  + 

1  aps* (30.d0+15.0d0*bps+aps) )+ 

1  bps* (180.0d0+bps* (30 . OdO+bps) )+120.d0) ) /32.0d0 
return 

75  ck«srpi8*srzi**nl 

joo«ck*exp  (ab2+d+abh)  *  { 

1  ap*  (bp* (360. OdO+bps* (120 .  OdO+6 . 0d0*bps) )  + 

1  ap* (180. OdO+bps* (180. OdO+15. 0d0*bps) + 

1  ap* (bp* (120.0d0+20.0d0*bps)+ 

1  ap* (30. 0d0+15. 0d0*bps+ap* (6 . 0d0*bp+ap) ) ) ) ) + 

1  bps*  (180. OdO+bps* (30 . OdO+bps) > +120 . OdO) / (32 . 0d0*ap*bp) 
return 
c 

c  integrate  using  expansion  of  small  arguement  if  neccessary 
c 

500  if  (bh.lt.O. Id0)goto6l0 
if  (ah.lt.0.1d0)goto600 
c 

a=2 . OdO*ah 
b*2 . OdO*bh 
zz«2 . OdO*ah*bh 
ab2«  ah*ah+bh*bh 
xp=ah+bh 
xm*bh-ah 

call  dawv(dawsp,daws3p,xp) 

if (zz  . gt. 18 . 0d0)goto85 

exzp-exp (zz) 

exzm»l . OdO/exzp 

dOp=dawsp*exzp 

call  dawvfdawsm, daws3m,xm) 

dOm=dawsm*exzm 

d0s=d0p+d0m 

d0d=d0p-d0m 

dld=0 . 5d0* (exzp-exzm) 

if  (zz.lt.0.1d0)dld=dsinh(zz) 

joo-3rpi8*exp(ab2+d) * (srzi**nl) * (b*d0d+a*d0s-2 . 0d0*dld) / (ah*bh) 
return 

85  joo=srpi8*exp (ab2+d+zz)  *srzi**nl* ( (b+a) *dawsp-l . OdO) / 

1  (ah*bh) 
return 

600  ch=bh 
bh*ah 
ah*ch 
iswap»l 

610  z«2.0d0*bh*bh 
x2«ah*ah 

expa=exp (ah*ah+d) 
call  dawv(daws,daws3f ah) 
if (ah.lt.0.3d0)gotoll0 
vmO-2 . 0d0*daws/ah 
go  to  111 

110  vm0-2.0d0*(1.0d0+daws3) 

111  continue 
vm2-l . OdO 
vm4»x2+l . 5d0 
vm6»x2*v5+2 . 5d0*vm4 
vm8«x2*v7+3 . 5d0*vm6 
z3-z*0.33333333333333d0 
zlO-O . Id0*z 
z21-z/21.0d0 
z36»z/36. OdO 

'loi 


lopas . sub 


Fri  Apr  5  11:22:53  1991 


131 


cOO-expa* (srzi**nl) *srpi8*2 . OdO 

joo-cOO* (vm0+z3* (vm2+zl0* (vm4+z21* (vm6+z36*vm8) ) ) ) 
if (iswap.eq. l)goto222 
return 
222  ch-bh 
bh-ah 
ah=ch 
return 

999  write (60, 9999) 

9999  format (lx, ' illegal  order  of  r  see  joo') 
stop 
end 

double  precision  function  jlo(n) 
c  version  #2  jan  10  1985  c. woodward 

c  this  function  evaluates  integrals  stemming  from  a  three  center 
c  integrand,  the  integrand  includes  two  modified  spherical  bessel 
c  functions  of  the  first  kind  (1=1  and  1=0)  with  different  arguements, 
c  a  gaussian  and  r**n. 

implicit  double  precision (a-h, j, o-z) 
integern 

common/ jprm/srzi, ah,bh,d 
data  srpi8/0 . 221 5567 31 3632 5d0/ 
nl=  n  +1 
c 

c  go  to  special  cases  if  n  <  11  +  12  +  2 
c 

if  (n  . It . 3) gotoSOO 

c 

ap=2 . 0d0*ah 
bp=2 . 0d0*bh 
aps=ap*ap 
bps “bp* bp 
ab=ah*bh 
ahs=  ah*ah 
bhs=  bh*bh 
ab2=  ah*ah+bh*bh 
abt=ah*bh*2 . OdO 
ap3=aps**3 . OdO 
bp3=aps*aps*bps 
bpah=  (ah+bh) 
bmah=  (bh-ah) 
c 

c  otherwise  evaluate  jlo 
c 

goto  (10,999,30,999,40), (n-2) 
goto  999 
c 
c 

10  if (abt.gt. 18.d0)gotoll 
ck=3rpi8*exp (ab2+d) * (srzi**nl) 
if (abt.gt.O. 3d0)gotol5 

jlo=2 . 0d0*ck*dcosh (abt) * (ahs+ 

#  (ahs  -  0.5d0) *tanh3 (abt) ) /ah 
return 

15  jlo-  ck* (dcosh (abt) * 

#  bh  +  (ah- (0 . 5d0/ah) ) *dsinh (abt) ) /ab 
return 

11  jlo=srpi8*exp (ab2+d+abt) *srzi**nl* (ah+bh-. 5d0/ah) /abt 
return 


30  if (abt.gt. 18. OdO) goto31 

ck»srpi8*exp (ab2+d) * (srzi**nl) 

Zip') 
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if (abt .gt . 0. 3d0) goto35 
jlo-  ck*dcosh(abt) * 

4  (bh*  (2 . 0d0*ahs*  (1 .  OdO+ahs+3. 0d0*bhs)  -bhs-0 . 5d0) 

#  *tanh3  (abt)  +ahs*bh*  (2 . 0d0*ahs+5 . 0d0+6 . 0d0*bhs) )  /ab 
return 

35  jlo«ck*dcosh(abt) * (bh* < 

#  bhs+3 . 0d0*ahs+0 . 5d0)  +  (ah*  (ahs+l .  OdO-0 . 25d0/ahs+ 

#  bhs*  (3.0d0-0.5d0/ahs) ) ) *dtanh(abt) ) /ab 
return 

31  jlo«srpi8*exp(ab2+d+abt) *srzi**nl*  (bpah*  (1.5d0+bpah*  (bpah 

l-.5d0/ah) )-. 25/ah) /abt 
return 


40  if  (abt.gt.l8.d0)goto41 
ck»srpi8*exp(ab2+d) *  <srzi**nl) 
if  (abt.lt.0.3d0)goto45 

jlo*ck*  (dcosh(abt)  *bp*  (12  .  OdO+bps*  (12  .  OdO+bps)  + 
laps* (52 . 0d0+10 .d0*bps+5. 0d0*aps) )  +dsinh (abt) *  ( 
laps* (36. OdO+bps* (48 . OdO+5 . 0d0*bps) + 

laps*  (18 . 0d0+10  .d0*bps+aps) )  -bps*  (24  .  OdO+2 . 0d0*bps)  -24  .  OdO)  /ap) 
1/ (16.0d0*abt) 
return 

45  jlo«ck*dcosh  (abt)  *  (aps*  (140  .dO+bps*  (68 . 0d0+5. 0d0*bps)  + 
laps*  (28  .d0+10. 0d0*bps+aps) )  +tanh3  (abt)  *  (aps*  (36 .  OdO+bps* 

1  (48  .d0+5. 0d0*bps)  +aps*  <18 . 0d0+10 . 0d0*bps+aps) )  -bps*  (24.  OdO 
1+2 . OdO* bps) -24 . OdO) ) / (ap*16 . OdO) 
return 

41  jlo»srpi8*exp(ab2+d+abt)  *srzi**nl* ( 
lap* (bp* (12 . OdO+bps* (12 . OdO+bps) ) + 
lap* (36. OdO+bps* (48 . OdO+S . 0d0*bps) + 
lap* (bp* (52. 0d0+10 . 0d0*bps) + 

lap* (18 . 0d0+10.d0*bps+ 
lap* (5 . 0d0*bp+ap)  )  )  )  )  - 

lbps* (24 . 0d0+2. 0d0*bps)  -24  .  OdO) / (16 . 0d0*aps*bp) 
return 
c 

c  go  to  the  expansions 
c 

500  if (bh  . It . 0 . ldO) goto610 
if (ah  . It . 0 .ldO) goto600 
c 

zz«2 . 0d0*ah*bh 
a-2 . 0d0*ah 
b-2.0d0*bh 
xp-ah+bh 
xm*bh-ah 
ahs-  ah*ah 
bhs«  bh*bh 
abt-2.0d0*ah*bh 
ab2»  ah*ah+bh*bh 
call  dawv(dawsp,daws3p,xp) 
call  dawv  (dawsm,  daws3m,  xm) 
c 

c  evaluate  n*«l  or  n--l 


c 

c  if  (n  .eq.  -l)go  to  60 

c*  (n»-l  is  not  used  at  this  time)  * 

c** *******************  ******************** 
c 

if(zz  .gt.l8.0)goto42 
ck-srpi8*exp(d+ab2) *srzi**2 . OdO 
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buff-exp(zz) *4 . OdO* (1 . OdO-b*dawap) 
buf f-buf f-exp (-zz) *4 . OdO* (1 . OdO-b*dawam) 
jlo-  ck*buf f / (b*a*a) 
return 

42  jlo-arpi8*  (arzi**2.  OdO)  *exp  (d+ab2+zz)  *4 .  OdO*  (1 .  OdO-b*dawap) 
1/ <b*a*a) 
return 
c 

c  evaluate  n— 1 
c 

c  60  if  (zz  .gt.  18.0d0)goto  61 
c  dlt— 0. 6666666666666d0* (ah*bh*dcoah (zz) + 

c  #  (-2. 0u0*aha+bhs-l . OdO) *dsinh (zz) ) 

c  if  (zz  .It.  0 . 3d0)  dlt— 0 . 6666666666666d0* 

c  #  dcoah (zz) * (zz* (2 . 0d0*ahs+bhs-0 . 5d0) +zz* 

c  #  (2. 0d0*aha+bha-l . OdO) *tanh3 (zz) ) 

c  exzp-exp(zz) 

c  exzm-1 . OdO/exzp 

c  dOp-dawap*exzp 

c  dOm-dawsm*exzm 

c  dOa-dOp+dOm 

c  d0d=d0p-d0m 

c  d2t-d0a*4 . 0d0*ahs*ah/3. OdO 

c  d3t-d0d*bh* (1 . OdO+2 . 0d0*aha-0. 6666666666666d0*bhs) 

c  jlo«srpi8*exp (ab2+d) * (dlt+d2t+d3t) / (bh*aha) 

cc  return 

c  61  dlt— 0.3333333333333d0*  (ah*bh 
c  #  -2 . 0d0*aha+bhs-l . OdO) 

c  d2t-dawap* (4 . 0d0*aha*ah/3 . OdO+bh* (1 . OdO+2 . OdO*ahs- 

c  #  0. 6666666666666d0*bha) ) 

c  jlo»srpi8*exp (ab2+d+zz) * (dlt+d2t> / <bh*ahs) 

c  return 

c 

c  now  do  the  expansions  for  small  bh 
c 

610  z-2.0d0*bh*bh 
ahs»ah*ah 
bhs-bh*bh 
expa«exp (ah*ah+d) 
call  dawv(daws,dawa3,ah) 
vjn0*2 . 0d0*dawa/ah 
if (ah . It . 0 . 3d0) gotollO 

dO- (daws* (2 . 0d0*ah+l . OdO/ah) -1 . OdO) /ah a 
dl- (1 . OdO-O . 5d0*vm0) /aha 
go  to  111 

110  dl— dawa3/aha 

d0-dawa3* (1 . OdO/aha+2 . OdO) +2 . OdO 

111  continue 
d2-  l.OdO 

d3-  (2 . 5d0+ahs) 

d4-  (8.75d0+ahs* (7.0d0+aha) ) 

d5-  (39. 375d0+aha* (47 . 25d0+aha* (13 . 5d0+ahs) ) ) 

cl-  2.0d0*bhs/3.0d0 

c2-  bha/5.0d0 

c3-  2 . OdO*bhs/21 . OdO 

c4-  bha/18.0d0 

c5-  2 . 0d0*bha/55 . OdO 

if(n  ,eq.-l)goto630 

jlo-2. 0d0*arpi8*expa*  (arzi**nl)  *ah*  (dl+cl*  (d2+c2*  (d3+c3* 
t  (d4  +  c4*d5) ) ) ) 
return 

630  jlo-2. 0d0*srpi8*expa*ah* (dO+cl* (dl+c2*  (d2+c3* 

#  (d3  +  c4*(d4  +  c5*d5) ) ) ) ) 

return 
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c 

c  now  do  the  expansions  for  small  ah 
c 

600  z-2.0d0*bh*bh 
ahs-ah*ah 
bhs-bh*bh 
expb-exp (bh*bh+d) 
call  dawv(daws,daws3,bh) 
dO-  2 . 0d0*daws/bh 

if (bh . It . 0 . 3d0 ) dO- (1 . 0d0+daws3) *2 . OdO 
dl-  l.OdO 
d 2-  bhs+l.SdO 
d3-  3.75d0+bhs* (5. OdO+bhs) 

d4-  13. 125d0+bhs* (26.25d0+bhs* (10.5d0+bhs) ) 
d5-  59 . 0625d0+bhs*  (157. 5d0+bhs* (94 . 5d0+bhs* 

#  (18. OdO  +  bhs) ) ) 
cl*  ahs*0.40d0 

c2*  ahs/7 . OdO 

c3*  2 . 0d0*ahs/27 . OdO 

c4-  ahs/22.0d0 

c5-  2 . Od0*ahs/65 . OdO 

if(n  .eq. -I)goto640 

jlo*  4 . 0d0*ah* (srzi**nl) *srpi8*expb* (dl+cl* (d2+c2* 

#  (d3  +  c3*(d4  +  c4*(d5  +c5) ) ) ) ) /3 . OdO 

return 

640  jlo-  4 . 0d0*ah*srpi8*expb* (dO+cl* (dl+c2* (d2+c3* 

#  (d3  +  c4*(d4  +  c5*d5) ) ) ) ) /3. OdO 
return 

999  write  (60, 9999) 

9999  format (lx, 'odd  power  of  r  is  not  valid.  see  jlo.') 
stop 
end 

double  precision  function  jol (n) 
c  version  #2  jan  10  1985  c. woodward 

c  this  function  evaluates  integrals  stemming  from  a  three  center 
c  integrand,  the  integrand  includes  two  modified  spherical  bessel 
c  functions  of  the  first  kind  (1-0  and  1-1)  with  different  arguements, 
c  a  gaussian  and  r**n. 

implicit  double  precision (a-h, j, o-z) 

common/ jprm/srzi,  ah, bh,d 

integern 

data  srpi8/0 . 22 15567 31 36 32 5d0/ 
c 

ch-ah 

ah-bh 

bh-ch 

jol-jlo (n) 

ch-ah 

ah-bh 

bh-ch 

return 

end 

double  precision  function  jll (n) 
c  version  #2  jan  10  1985  c. woodward 

c  this  function  evaluates  integrals  stemming  from  a  three  center 
c  integrand,  the  integrand  includes  two  modified  spherical  bessel 
c  functions  of  the  first  kind  (1-1)  with  different  arguements, 
c  a  gaussian  and  r**n. 

implicit  double  precision (a-h, j,o-z) 
integern 

common/ jprm/srzi, ah, bh,d 
data  srpi8/0.22155673136325d0/ 
iswap-0 
nl-  n  +1 
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go  to  special  cases  if  n  <  11  +  12  +  2 

if  (n  .lt.4)goto500 

ap-2.0d0*ah 
bp-2. OdO *bh 
ab-ah*bh 
ahs-  ah*ah 
bhs-  bh*bh 
ab2-  ah*ah+bh*bh 
abt-ah*bh*2 . OdO 
bpah-  (ah+bh) 
bmah-  (bh-ah) 

otherwise  evaluate  jll 

goto(10, 20,  30) (n-2) /2 
go  to  999 

evaluate  jll (4) 

L0  if  (abt.gt.l8.0d0)gotoll 

ck«srpi8*exp(ab2+d) * (srzi**nl) 

if (abt.lt .0.3d0)gotol5 

jll-  ck* (dcosh(abt) * (ahs+bhs- 

#  0.5d0)  +  (abt- (ahs+bhs-0 . 5d0) /abt) *dsinh (abt) ) /ab 
return 

L5  jll-  ck*dcosh (abt) * (abt*abt+ 

#  (abt*abt-ahs-bhs+0. 5d0) *tanh3 (abt) ) /ab 
return 

LI  ck-srpi8*srzi**nl 

jll-  ck*exp (ab2+d+abt) * (ahs+bhs-0 . 5d0+ 

#  (abt- (ahs+bhs-0. 5d0) /abt) ) /abt 
return 

evaluate  jll (6) 

20  x2h-ab2-0 . 5d0 
x2p-ab2+0 . 5d0 
if (abt.gt.l8.0d0)gotol7 
ck-srpi8*exp(ab2+d) * (srzi**nl) 
if  (abt.lt.0.3d0)goto75 

jll-ck* ( (x2p* (2 . 0d0*abt*abt-x2h) +abt*abt-ab2) *dsinh (abt) /abt+ 

#  (x2p*x2p+abt*abt-0 . 5d0) *dcosh (abt) ) / (abt*0. 5d0) 
return 

(5  jll-ck*dcosh (abt) *2 . OdO* ( (ab2+l . 5d0) *2 . 0d0*abt+tanh3  (abt) * 

#  (x2p* (2. 0d0*abt*abt-x2h) +abt*abt-ab2) /abt) 
return 

L7  ck-srpi8* (srzi**nl ) *exp (ab2+d+abt) 

jll-ck* ( (x2p* (2 . 0d0*abt*abt-x2h) +abt*abt-ab2) /abt+ 

#  (x2p*x2p+abt*abt-0.5d0) ) / (abt) 
return 


30  as-ap*ap 
bs-bp*bp 

if  (abt.gt.l8.0d0)goto31 

ck-srpi8*srzi**nl*exp(ab2+d) 

if  (abt . It . 0 . 30d0 ) goto35 

tl- (as* (bs* (140 . 0d0+15. 0d0*bs) +36 . 0d0+ 

1  as* (18.0d0+15.0d0*bs+as) )+ 

1  bs  * ( 3  6 . OdO+bs • ( 1 8 . dO+bs ) ) -2  4 . dO ) / 64 . dO 
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t2- (as* (-36 . dO+bs* (72 . dO+bs* (45 . dO+3 . dO*bs) >  + 

1  as* (-18. dO+bs* (45.d0+10.d0*bs) + 

1  as* (3.d0*bs-l . OdO) ) ) 

1  -bs*  (36 .dO+bs* (18 .dO+bs) ) +24 . dO) / (32 . 0d0*ap*bp) 
jll-ck* (dcosh (abt) *tl+dsinh(abt) *t2) / (ah*bh) 
return 

35  jll-ck*dcosh (abt) * (as*bs* <aa* (60 . 0d0+10. OdO*bs+3 . OdO*as) + 
lbs*  (60 . OdO+3. 0d0*bs) +212 . dO ) +tanh3 (abt) *  ( 
las* (-36. OdO+bs* (72 . OdO+ba* (45 . OdO+3 . OdO*ba) ) + 
las* (-18 . OdO+bs* (45 . 0d0+10 . OdO*bs) + 

las*  (-1 . OdO+3 . OdO*bs) ) ) -bs* (36 .  OdO+bs* (18 . OdO+bs) ) +24 . OdO) ) 

1/ (16. OdO*ap*bp) 
return 

31  ck-srpi8*srzi**nl 

tl-(ap* (bp* (-24. OdO+bs* (36. OdO+bs* (18. OdO+bs) ) )+ 

1  ap* (-72 . OdO+bs* (144 .  OdO+bs* (90 . OdO+6 . OdO*bs) )  + 

1  ap* (bp* (36. OdO+bs* (140 . OdO+15 . OdO*bs) ) + 

1  ap* (-36. OdO+bs* (90. 0d0+20 . OdO*bs) + 

1  ap* (bp* (18. OdO+15. OdO *bs)+ 

1  ap* (-2 . OdO+6. OdO*bs+ap*bp) )))))- 

1  bs*  (72. OdO+bs*  (36. OdO+2 . OdO*bs) ) +4 8. OdO)  /  (64  .  OdO*ap*bp) 
jll«ck*exp (ab2+abt+d) *tl/abt 
return 
c 
c 

c  check  to  see  if  ah  or  bh  is  less  than  0.1 
c 

500  if (bh.lt. 0.1d0)gotol01 
if (ah.lt. 0.1d0)goto201 
c 

ab2-ah*ah+bh*bh 

zz-2.0d0*ah*bh 

a*2 . 0d0*ah 

b-2.0d0*bh 

xp-ah+bh 

xm-bh-ah 

call  dawv(dawsp,daws3p,xp) 
c  dOp-dawsp*exzp 

call  dawv(dawsm, daws3m, xm) 
c 

go  to  (55, 999, 555) n+1 
goto  999 
c 

c  n«-2 
c 

c  ck-srpi8*exp(ab2+d) * (srzi**nl) 

c  5  if  (zz  .It.  0.3d0)  go  to  51 

c  fl-  2 . OdO* (dcosh (zz) *a*b* (4 . 0d0-b*b-a*a) +dsinh (zz) * 

c  #  (a*a*  (a*a-4 . OdO* (b*b+2 . OdO) )  +b*b* (b*b-8 . OdO) -8 . OdO) ) 

c  go  to  52 

c  51  fl-  2.0d0*dcosh(zz)*(a*b*(-4.0d0+b*b*(b*b-9.0d0) 

c  #  +a*a* (a*a-4 . 0d0*b*b-9 . OdO) )  +  (a*a* (a*a-4 . OdO* (b*b+2. OdO) ) 

c  #  +b*b* (b*b-8 . OdO) -8.  OdO)  *tanh3 (zz) ) 

c  52  jll-  2 . OdO*ck* (fl+dOp*a*a*a* (5 . OdO* (b*b+2 . OdO) 

c  #  -a*a) +dOm*b*b*b* (5 . OdO* (a*a+2 . OdO) -b*b) ) / (15 . OdO*a*a*b*b) 

c  return 

c 

c  n-0 
c 

55  if  (zz.gt.l8.0)goto56 

ck-srpi8* (srzi**nl) *exp(ab2+d) 

buff-exp (zz) * (a*a+b*b-a*b+2 . OdO- (a**3+b**3) *dawsp) 
buff-buff-exp(-zz)  *  (a*a+b*b+a*b+2. 0d0+  (a**3-b**3)  *dawsm) 
jll-ck*buf f *4 . OdO/ (3 . 0d0*a*a*b*b) 
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return 

56  cJc-srpi8*  (srzi**nl)  *exp(ab2+d+zz) 

buff-(a*a+b*b-a*b+2.0d0- (a**3+b**3) *dawsp) 
jll«ck*buf f *4 . OdO/  (3. 0d0*a*a*b*b) 
return 
c 

c  n«2 
c 

555  if(zz  .gt.l8.0d0)goto556 
ck«srpi8* (srzi**nl) *exp(ab2+d) 
buff-exp(zz) * (a*b-2.0d0) 

buf f-buf f +exp (-zz) * (a*b+2 . OdO) 
jll-ck*buf f*2 . OdO/  (a*a*b*b) 
return 

556  buff«exp(ab2+d+zz) *  (a*b-2. OdO) 
ck«srpi8* (srzi**nl) 
jll-ck*buf  f  *2  .  OdO/  (a*a*b*b) 
return 

c 

c  evaluate  small  ah,bh 
c 

201  ch-bh 
bh-ah 
ah-ch 
i swap-1 

101  z-2.0d0*bh*bh 
x2-ah*ah 

expb-exp (ah*ah+d) 
call  dawv (daws, daws3, ah) 
vmO-2 . 0d0*daws/ah 
if (ah.lt.0.3d0)gotoll0 

vO-  (daws* (2 . OdO*ah+l . OdO/ah)  -1 . OdO) /x2 
vl- (1 . OdO-O . 5d0*vm0) /x2 
go  to  111 

110  vl—  daws3/x2 

vO-  (daws3* (2 . 0d0+l . 0d0/x2) +2 . OdO) 

111  continue 
vm2-  l.OdO 
v3-  l.OdO 
vm4-  x2+1.5d0 
v5-  x2+2 . 5d0 

vm6«  x2*v5+2 . 5d0*vm4 
v7  -  (x2+2.0d0) *v5+2.5d0*vm4 
v9  -  (x2+3 . OdO) *v7+3. 5d0*vm6 
c00«expb*2.0d0 

c01-c00*bh*0.66666666666666d0 

cll-c01*ah* (srzi**nl) *srpi8 

z5«  0.2d0*z 

zl4-  z/14 . OdO 

z27-  z/27 . OdO 

z44-  z/44 . OdO 

goto  (105,106,107),  (n+4)/2 

106  jll-cll* (vl+z5* (v3+zl4* (v5+z27* (v7+z44*v9) ) ) ) 

if  (iswap.eq.l)goto222 
return 

107  continue 
vm8»x2*v7+3 . 5d0*vm6 

vl 1* (x2+4 . OdO) *v9+4 . 5d0*vm8 

jll-cll* (v3+z5* (v5+zl4* (v7+z27* (v9+z44*vll) ) ) 

if (iswap.eq. 1) goto222 

return 
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c 

105  jll-  cllMv0+z5*(vl+zl4Mv3+z27Mv5+z44*v7)))) 
if (iswap.eq. l)goto222 
return 
c 

222  ch-bh 
bh«ah 
ah«ch 
return 
c 

999  write (60, 9999) 

9999  format (lx,'  power  of  r  is  not  valid,  see  jll.') 
stop 
end 

c  large  uhf  code  for  use  on  scalar  computers 
c  high  speed  accelerated  convergence  procedures 
c  based  on  1978  mrl  code  of  a  b  kunz 
c  modified  by  a  b  kunz  in  1989 

c  ultimately  is  trivially  modified  for  large  scale 

c  parallel  processing, with  mosi  changes  occuring  in 
c  subroutine  two 

c  language  is  essentially  fortran  77 

c  speed  up  is  from  accelerated  use  of  sparseness  and 
c  labels  output  on  file  3 

c  poly in  output  on  file  4 

c  input  data  on  file  5 

c  output  on  file  6 

c  scratch  data  in  arrays  al,  a2,...a9,  a,  b,  c 

c  restart  vectors  on  file  20 

c  single  precision  mbpt  output  on  file  30 

c  *********  this  code  is  in  double  precision  form  ********* 
subroutine  uhf (iblk, ilopas) 
implicit  double  precision  (a-h,o-z) 

c  *  to  redimension  this  code  change  the  parameters  in  statements  2700,2800 
c  *  4800  through  5100  according  to  the  formulae  given, 

c  * 

c  *********************************************************************** 

c  **  program  limitations  and  dimensioning  variables  ** 

integer*2  rdate(9) 
real*4  tyme<2) 
real*8  rdtime 
character*16  nam 

character*ll  mol04 (20) ,mol5b (20) ,moll6 (20) ,mol20 (20) , 
lmol30 (20) ,mol02 (20) 
characterM  za,  zb,  zc,  zd,  zl,  zn 

common  enrep,nup, ndn/al/al (32400) /a2/a2 (32400) / a3/a3 (32400) / 

1  a4/a4  (32400) /a5/a5 (32400) /a6/a6 (32400) /hu/hu  (16290)  / 

1  hd/hd (16290) /a/a (32400)  /b/b  (32400) /e/e  (2,180)  / 

1  iup/iup  (180)  /idn/idn  (180)/rr/rr(180)  /holdup/ 

1  holdup(180)  /holddn/holddn  (180)  /hold/hold(180)  /sav/ 

1  sav(1024)/rovr/rovr(180) 
common/files/nbas,  ifile,maxbas 
common/inxcm/isnx  (180) 
common/lb/ipak (1024) 
real  ss 

dimension  zl  (20) ,afmt (4),za(180),zb(180),zc(180),zd(180) 
dimension  zn(2) 

dimension  a7 (32400) ,  a8 (32400) ,  a9 (180) 
dimension  workl (180) ,  work2 (180) , ss  (180) 
character*ll  mol52(20) 
integer*2  iii,jjj 

dimension  exv(1024) , vxt (256, 256) , iii (1024) , j j j (1024) , 
lai j  (2, 256, 256), si j <2, 256, 256) 
mol52(l) -'mol5201.dat' 
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mol52(2)-'mol5202.dat' 
mol52(3)-'mol5203.dat' 
mol52 (4) «'mol5204 .dat' 
mol52  (5) -'mol5205.dat' 
mol52  (6)  “'mol5206.dat' 
mol52 (7) -'mol5207.dat' 
mol52 (8) -'mol5208.dat' 
mol52(9)«'mol5209.dat' 
mol 52 (10) “'mol5210.dat' 
mol 52 (11) -'mol5211 .dat' 
mol52 (12) “'mol5212.dat' 
mol52 (l3)«'mol5213.dat' 
mol 52 (14)«'mol5214 .dat' 
mol52(15)«'mol5215.dat' 
mol52(l6)«'mol5216.dat' 
mol52(17)»'mol5217.dat' 
mol52 (18) “'mol5218.dat' 
mol52  (19) «' mol5219.dat' 
mol52 (20) -'mol5220.dat' 
mol 04 (1) »'mol0401 .dat' 
mol04(2)«'mol0402.dat' 
mol 04 (3) “'mol0403.dat' 
mol04 (4) «'mol0404 .dat' 
mol  04 (5) ■' mol0405.dat' 
mol04 (6)”'raol0406.dat' 
mol 04 (7)«'mol0407 .dat' 
mol 04  (8)-'mol0408.dat' 
mol04 (9) -'mol0409.dat' 
mol 04 (10) “'mol0410.dat' 
mol 04  (ll)«'mol0411 .dat' 
mol 04 (12) “'mol0412.dat' 
mol 04 (13) -'mol0413.dat' 
mol04(14)-'mol0414.dat' 
mol 04 (15) “'mol0415.dat' 
mol 04 (16) -'mol0416.dat' 
mol04 (17) «'mol0417 .dat' 
mol 04 (18) “'mol0418.dat' 
mol 04 (19) "'mol0419.dat' 
mol04(20)-'mol0420.dat' 
mol 5b ( 1 ) *' mol 5b0 1 . dat ' 
mol5b (2) -'mol5b02.dat' 
mol5b (3) “'mol5b03.dat' 
molSb (4) -'mol5b04.dat' 
mol 5b (5) -'mol5b05.dat' 
mol5b (6) «'mol5b06 .dat' 
mol5b (7) -'mol5b07.dat' 
mol 5b (8) -'mol5b08.dat' 
mol5b (9) -'mol5b09.dat' 
mol5b (10) -'mol5bl0.dat' 
mol 5b (11) -'mol5bll.dat' 
mol5b (12) -'mol5bl2.dat' 
molSb (13) -'mol5bl3.dat' 
mol5b(14)-'mol5bl4 .dat' 
molSb (15) -'mol5bl5.dat' 
mol5b (16) -'mol5bl6.dat' 
mol5b (17) -'raol5bl7.dat' 
mol 5b (18) »' mol5bl8.dat' 
molSb (19) -'mol5bl9.dat' 
mol5b( 20) “'mol5b20.dat' 
moll6 (1) -'moll601 .dat' 
mollfi (2) -'moll602.dat' 
moll6(3)-'moll603.dat' 
moll 6  (4) -'moll604.dat' 
moll 6 (5) -'moll605.dat' 
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moll6 (6) -'moll606.dat' 
moll6 (7)  -'moll607.dat' 
moll  6 (8) -'moll 608 .dat' 
moll 6 (9) -'moll609 .dat' 
moll6(10)-'moll610.dat' 
moll 6 (11) -'moll 611 .dat' 
moll6 (12) -'moll612.dat' 
moll6(13)-'moll613.dat' 
moll 6 (14) -'moll614.dat' 
moll6(15)-'moll615.dat' 
moll6(16)-'moll616.dat' 
moll6(17)-'moll617.dat' 
moll 6 (18) -'mol 161 8 .dat' 
moll6(19)-'moll619.dat' 
moll6(20)-'moll620.dat' 
mol20 (1) -'mol2001.dat' 
mol20 (2) ='mol2002 .dat' 
mol 20 (3)-'mol2003.dat' 
mol 20  (4) -'mol2004 .dat' 
mol20 (5) -'mol2005.dat' 
mol 20 (6) -'mol2006.dat' 
mol20  (7) -'mol2007.dat' 
mol20 (8) -'mol2008.dat' 
mol20 (9) -'mol2009.dat' 
mol20(10)-'mol2010.dat' 
mol 20 (11) -'mol2011.dat' 
mol 20 (12) -'mol2012.dat' 
mol20(13)-'mol2013.dat' 
mol20 (14) -'mol2014 .dat' 
mol20(15)-'mol2015.dat' 
mol20(16)-'mol2016.dat' 
mol20(17)-'mol2017.dat' 
mol20 (18) -'mol2018 .dat' 
mol20(19)-'mol2019.dat' 
mol20 (20) -'mol2020 .dat' 
mol30(l)-'mol3001.dat' 
mol30 (2) -'mol3002.dat' 
mol30 (3)-' mol3003.dat' 
mol 30 (4 ) -' mol3004 . dat' 
mol30 (5) -'mol3005.dat' 
mol30 (6) -'mol3006.dat' 
mol 30 (7) -'mol3007.dat' 
mol30 (8) -'mol 3008 .dat' 
mol30 (9) -'mol3009.dat' 
mol30 (10) -'mol3010.dat' 
mol30  (11) «'mol3011 .dat' 
mol30(12)-'mol3012.dat' 
mol30 (13) -'mol3013.dat' 
mol30(14)-'mol3014.dat' 
mo!30 (15) -'mol3015.dat' 
mol 30 (16) «'mol3016 .dat' 
mol30(17)-'mol3017.dat' 
mol30 (18) -'mol3018.dat' 
mol30(19)-'mol3019.dat' 
mol30 (20) -'mol3020 .dat' 
mol 02 (1) -'mol0201 .dat' 
mo!02 (2) -'mol0202 .dat' 
mol02 (3) -'mol0203.dat' 
mol02 (4) »'mol0204 .dat' 
mol02(5)-'mol0205.dat' 
mol 02 (6) -'mol0206.dat' 
mol02 (7) -'mol0207.dat' 
mol02 (8) -'mol0208.dat' 
mol02 (9) -'mol0209.dat' 
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mol02 (10) «'mol0210 .dat' 
mol 02 (11) -'mol0211 .dat' 
mol 02 (12) -'mol 0212. dat' 
mol02 (13)-'mol0213.dat' 
mol02 (14) «'mol0214 .dat' 
mol 02 (15) *' mol 02 15. dat' 
mol 02 (16) -'mol0216.dat' 
mol02 (17) -'mol0217 .dat' 
mol 02 (18) -'mol0218.dat' 
mol 02 (19) »'  mol0219.dat' 
mol 02  (20) -'mol0220.dat' 
c  **  program  limitations  ** 

naxbas-180 
naxup-180 
naxdn-180 
mqxbas-32400 
nuptri-16290 
maxrec-360 
mplusl-16291 
maxbas-180 
maxup-180 
maxdn-180 
muptri-16290 

c  where:  mqxbas=maxbas*maxbas 
c  (nuptri)muptri-  (maxbas+1) *maxbas/2 

c  maxrec-2*maxbas-file  20  double  precision  record  size 

c  (naxup)maxup-maximum  number  of  spin  up  orbitals 

c  (naxdn)maxdn-maximum  number  of  spin  down  orbitals 

c  mplusl*muptri+l 

c  **  note  that  it  is  assumed  throughout  the  code  that  maxup=maxdn 
open  (unit-5,  file==mol04  (iblk)  ,  form-'  formatted' ) 
open  (unit-60,  file*mol5b  (iblk) ,  form-'  formatted' ) 
open  (unit-4,  file-moll6  (iblk) ,  form-' unformatted' ) 
open  (unit-20,  file-mol20  (iblk) ,  form-' unformatted' , 
laccess-' direct' , reel-1440) 

1  format  (20a4, 2a4) 

2  format  (/lx, 20a4/8x, 9al, 2x, a8) 

3  format  {'1  mtu-physics  code  1989  version  unix  in  mind 
1  -  double  precision' ) 

31  format  ('  version  with  eispack' ) 

4  format  (20i4) 

5  format  (8fl0.5) 

51  format (lx, '  tol-' , 2x,  lpel2 . 5/lx, ' f racn-' ,  0pfl2.5) 

6  format  (80il) 

701  format (/5x, ' spin  up  input  orbitals') 

7  format  (lx, i2) 

702  format (/5x, ' spin  down  input  orbitals') 

8  format  (/'  up  spin' /lx, 80il) 

9  format (//'  initial  orbital  occupations') 

901  format (//'  final  iteration  orbital  occupations') 

10  format  (/'  down  spin' /lx, 80il) 

11  format  ('0  good  bye  for  now') 

12  format  ('0  converged') 

13  format  ('0  not  converged') 

14  format  ('0  results  in  hartrees,l  hy-2ry»27 . 2ev' ) 

15  format  ('0  state  ',i4,'  energy  -  ',fl4.6,'  hy  ') 

16  format  (lx,10fll.6) 

17  format  ('0  total  energy  -  ',fl6.6,'  hy' ) 

172  format  ('0  total  system  spin  «',fl0.6) 

173  format  ('0  ***problem  in  spin  computation:  <s**2>  «',fl0.6) 

18  format  ('0  self  consistency  (energy,  sqdif)  -  ',lpel2.3, 

1',  ' , el2 . 3) 

19  format  ('0  iteration  number  -  ',i3) 

21  format  (4a8) 
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22  format (16 {lx, 5dl5. 8/) ) 

23  format (2a4) 

24  format (lx, 2a4) 

241  format (//5x, ' nuclear  repulsion  energy  -',fl8.9) 

242  format (4x, 'lowest  overlap  eigenvalue  -',fl8.9/) 

245  formatt'O  energy-' , fl6 . 7, '  hy'//) 

255  format  ('0  nup  ndn  nbas  maxit  norm', 

1'  idat  iout  ifile  ivect' /3x, 9  (i4, 4x) //////) 

256  format (/'  Iwarning  -  iterating  to  an  excited  state  solution 

1  while  sorting  by  overlap  may  lead  to  unpredictable  results' ) 

260  format (//'  occupied  orbitals  -  spin  up') 

265  format (//'  virtual  orbitals  -  spin  up') 

270  format (//'  occupied  orbitals  -  spin  down') 

275  format (//'  virtual  orbitals  -  spin  down') 

6300  format  (lx, 'enter  the  name  of  the  uhfabk  input  file  (file  5)') 

32400  format (al6) 

61024  format  (lx, '  enter  the  name  of  the  uhfabk  information  output  file 
1  (file  6)') 

6600  format  (lx, 'enter  the  name  of  the  polyin  output  file  (file  4)') 

6700  format  (lx, 'enter  the  name  of  the  uhfabk  restart  file  (file  20)') 

6800  format  (lx, 'enter  the  name  of  the  mbpt  data  file  (file  30)') 

6900  format  (lx, 'enter  the  name  of  the  labels  output  file  (file  3)') 

do  101  j=l,maxba3 

101  isnx  ( j)  ** ( j*  ( j — 1 ) )  /2 

c  isnx  is  used  in  computing  the  index  of  elements  of  an  upper  triangular 

c  matrix  stored  as  a  linear  array 

iflag-0 

c  iflag*l  for  first  set  of  data 

c  >1  for  subsequent  sets  off  the  same  data  file 

c  (beware:  file  20  will  be  reused) 

2000  read (5, 1 ,end=1054 ) (zl (i)  ,  i-1 ,  20) ,  (zn( j) ,  j-1,2) 

if  (zl  (1) .eq. zn (1)  .and.  zl (2) .eq. zn (2) )  go  to  1054 

iflag-iflag+1 

write (60, 3) 

print  3 

write  (60, 31) 

print  31 

c  date  and  time  are  decsystem-20  macros 

write(60,2) (zl (i) , i-1, 20) ,  (rdate (j) , j-1, 9) , rdtime 
print  2,  (zl  (i) ,  i-1, 20) ,  (rdate  ( j) ,  j-1, 9) ,  rdtime 
do  25  i»l,maxup 
iup (i) -0 

25  idn (i) -0 
iter-0 
iusen-0 
idsen-0 
eto-0.0 
etn»0. 0 

read  (5, 4) nup, ndn, nbas, maxit, norm, idat, iout, ifile, ivect 
ifile-1 

if (ilopas.ne.0) idat-1 

write  (60,255)  nup, ndn,  nbas, maxit,  norm,  idat,  iout,  if ile,  ivect 

print  255, nup, ndn, nbas, maxit, norm, idat, iout, ifile, ivect 

imbpt-iout/2 

iout-iout-2  * imbpt 

istovp-ivect/2 

isqd-ivect-2*istovp 

if  (istovp.eq. 1 . and. norm. ne.0)  write (60, 256) 
if (imbpt. ne.l) go  to  430 

open  (unit-30,  file-mol30  (iblk) ,  form-'  unformatted' , 
laccess-'direct' , recl-720) 

430  if (iflag.gt . 1) go  to  44 
if (ifile. eq.0)go  to  44 
open (unit-3, file-mol02 (iblk) , 

7 


lop* 8 . sub 


Fri  Apr 


S  11:22:53  1991 


143 


1  form*' unformatted' ) 

44  ntot-nup+ndn 
is2*nbas*nbas 

if  (ntot.eq.O)go  to  1054 
read(5, 5) tol,  f racn 
if  (tol.eq.0.0)tol*.le-5 
if (fracn.eq. 0 .0) fracn*l . 0 
write (60,  51) tol, f racn 
print  51, tol, f racn 
if  (maxit.eq.0)maxit*20 
c  initialize  scratch  arrays 

nnn*maxba  s  *  maxba  s 
do  45  i=l,nnn 
al (i) *0.0 
a2 (i) *0 . 0 
a3 (i) -0. 0 
a4 (i)*0. 0 
a5 (i) *0 . 0 
a6 (i)-0.0 
a 7 (i)-0.0 
a8  (i) *0. 0 
a (i) *0 . 0 

45  b(i)*0.0 

c  input  vectors  loaded  into  al  and  a2,  and  output  to  file  6  between  statements  <7 

nd  290 

47  if  (idat.eq.0)  go  to  50 

if (idat.gt. 0)  go  to  32 
c  null  input  vectors 

id20*l 

do  28  j*l, nup 

write (20, rec=id20) (al(i),  i*l,nbas) 

28  id20*id20+l 

if (ndn.eq. 0) go  to  32 

id20-181 

do  29  j-l,ndn 

write (20, rec*id20) (a2(i),  i*l,nbas) 

29  id20*id20+l 

go  to  32 

c  read  vectors  off  of  file  5 

50  write (60, 701) 

do  282  i*l,nup 
za(i)«'i' 
zc(i)*'nup' 

read (5, 5) (rr ( j) ,  j*l,nbas) 
write (60,24) za (i) , zc (i) 
write (60, 22) (rr ( j) ,  j*l,nbas) 
do  282  k2*l,nbas 
k3-k2+ (i-1) *nbas 
282  al (k3) *rr (k2) 

if (ndn.eq. 0) go  to  290 
write (60, 702) 
do  285  i-l,ndn 
zb(i) *'i' 
zd(i)*'ndn' 

read(5,5) (rr ( j) ,  j-l,nbas) 
write  (60,24) zb(i) , zd(i) 
write(60,22) (rr(j),  j-l,nbas) 
do  285  k5-l,nbas 
n5* (i-1) *nbas+k5 
285  a2 (n5)*rr (k5) 

32  if (idat.eq.0)  go  to  290 

c  read  input  vectors  off  of  file  20 

id20*l 
11-1 
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nbas3-nbas 
do  288  j5-l,nup 

read (20, rec-id20) (al (j) ,  j-ll,nbas3) 
id20-id20+l 

11- ll+nbas 

288  nbas3-nbas3+nbas 

if (ndn.eq. 0)go  to  290 
id20-181 

12- 1 

nbas 4 -nbas 
do  2882  j6-l,ndn 

read (20, rec-id20) (a2(j),  j-12,nbas4) 
id20-id20+l 
12-12+nbas 

2882  nbas4-nbas4+nbas 

290  continue 

c  if  norm  .eq.  0,  set  orbital  occupations  for  lowest  nup  and  ndn  orbitals  to  one,  a 

others 

if (norm.ne. 0)go  to  38 
do  39  i«l,nbas 
iup(i)-0 

if  (i.le.nup) iup(i)«l 
idn (i)-0 

if (i.le.ndn)idn(i)*! 

39  continue 
go  to  40 

c  read  in  orbital  occupations  if  norm  .eq.  1 

38  read (5, 6)  (iup  (i) ,  i-1, nbas) 

if (ndn.ne. 0) read (5,  6)  (idn  (i) ,  i=l, nbas) 

40  continue 

if  ( nbas. gt.maxbas) stop  'too  damn  big' 
c  output  orbital  occupations  to  file  6 

write(60,9) 

write(60,8) (iup (i) , i-1,  nbas) 

if (ndn.ne. 0) write (60,10)  (idn (i) , i»l,nbas) 

c  rtime  is  a  decsystem-20  macro  which  returns  batch  time  left  for  the  job  to  run 

c  call  rtime (rta) 

call  one 

c  normalize  the  input  vectors 

if (idat.ne.O)go  to  202 
do  200  i-1, nup 

11-  (i-1) *nbas 

12- 11+1 

call  gdotpr (al (12) ,  a3,  al (12) ,  0, sum, nbas) 
sum-dsqrt  ( sum) 
do  200  j-l,nbas 
k2-ll+ j 

200  al (k2)  -al (k2) /sum 
do  201  i-1, ndn 

11-  (i-1) *nbas 

12- 11+1 

call  gdotpr  (a2  (12) ,  a3,  a2  (12) ,  0,  sum,  nbas) 
sum-dsqrt  (sum) 
do  201  j-l,nbas 
k2-ll+j 

201  a2 (k2) -a2 (k2) /sum 

202  if (idat.ne.l)go  to  203 

if (norm.ne. 2)go  to  203 

do  2022  i-1, nup 

if (iup (i) .eq.0)iupout-i 
if (iup(i) .eq.0)go  to  2023 

2022  continue 
iusen-1 

2023  if (ndn.eq. 0) go  to  203 

'I'Cl' 
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do  2025  i-l,ndn 
if (idn(i) .eq.O) idnout-i 
if (idn (i) .eq. 0) go  to  2026 

2025  continue 
idsen-1 

2026  continue 

if  (iusen.ne. 0)go  to  2050 
do  2030  j-1, nbas 

2030  holdup( j)-al ( (iupout-1) *nbas+ j) 

2050  if (idsen.ne.O)go  to  203 
do  2060  j-1, nbas 

2060  holddn(j)-a2( (idnout-1) *nbas+ j) 

203  do  60  i-1, nbas 

is* (i-1) *nbas 
do  60  j-1, nbas 
kl0»is+ j 

60  a8 (klO) »a3 (klO) 

c  put  overlap  matrix  into  packed  upper  triangular  form 

k-1 

do  100  j-2,nbas 
1-nbas* ( j-1) 
do  100  i-1, j 
1-1+1 
k-k+1 

100  a8(k)-a8(l) 

c  confute  eigenvalues  and  eigenvectors  of  the  overlap  matrix 

call  rsp  (nbas,nba3,mqxbas,a8,a9,l,a7,workl, 

&  work2,ierr) 

if  (ierr.ne.0)  stop  'trouble  in  eigenvalue  finder.' 
c  reverse  the  order  of  these  eigenvalues  and  vectors 

limit-nbas/2 
do  150  i-1, limit 
temp«a9 (i) 
a9  (i) -a9 (nbas-i+1) 
a9 (nbas-i+1 ) -temp 
il-nbas* (i-1) 
in-nbas* (nbas-i) 
do  150  j-l,nbas 
temp-a7 (il+ j) 
a7(il+j)-a7(in+j) 
a7 (in+ j)-temp 
150  continue 

c  output  nuclear  repulsion  energy  and  lowest  overlap  eigenvalue 
write  (60,241)  enrep 
write(60,242)  a9(nbas) 
c  iteration  loop  begins  here 

if (idat.lt.O)then 

c  provide  trial  eigenvalues  and  eigenfunctions 
c  copy  h  from  a4  to  a5 

do  3001  i-l,nbas*nbas 
a8(i)-a7(i) 

3001  a5(i)-a4(i) 

call  xroot  (nbas,  a5,  a9,  a8,  rr,  b,  workl,  work2) 
call  norms (nbas) 
c  trial  vectors  obtained 

c  write  to  disc  file  20  and  toal  and  a2 
do  3002  i-1, nbas 
do  3002  j-1, nbas 
k- (i-1) *nbas+ j 
al (k) -b(k) 

3002  a2(k)-b(k) 
id20-l 
120-181 

do  3003  i-1, nbas 
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11-  (i-1) *nbas+l 

12- 11-1+nbas 

write (20, rec-id20) (b(k) , k-11, 12) 

3003  write  (20, rec-id20) (b(k> ,k-ll, 12) 
c  begin  iterations 
endif 

1000  iter-iter+1 

c  shall  we  do  another  iteration? 

if (iter.gt .maxit)go  to  1001 
if (iter.eq.l)go  to  761 
c  call  rtime(rtb) 

c  elapst-rta-rtb 

c  rta-rtb 

c  if (rta.lt. (1.2*elapst) )go  to  990 

761  continue 

c  decision  loop  starts  here 
call  two 
c 

c*********************************************************************** 

c 

c  start  of  lopas  insert 
c 

£******★★***★*************************************★************★******** 

c 

do  899  i-1, 256 
do  899  j-1, 256 
899  vxt(i,j)«0.0 

if  (ilopas.eq. 0)  go  to  800 

open  (unit-52,  f ile-mol52  (iblk) ,  form-'  unformatted' ) 

801  read(52) ii, ifrst,iii, j j j,exv 
do  802  i-l.ii 

vxt  (iii (i) , j j j (i) )-exv(i) 

802  vxt(jjj(i),iii(i))-exv(i) 
if (ifrst.eq.O)go  to  801 
close (unit-52) 

c  form  sij  and  aij  here 
c  spin  up  sij  first 
do  803  i«l,nbas 
do  803  j«l,nup 
sij  (1, i, j) -0 . 0 
do  803  k«l,nbas 

803  si  j  (l,i,  j)-sij  (l,i,  j)+al  ( ( j-1)  *nbas+k)  *a3  ( (i-1)  *nbas+k) 

c  spin  down  sij  now 

do  804  i«l,nbas 
do  804  j«l,ndn 
sij  (2, i, j) -0 . 0 
do  804  k»l,nbas 

804  si  j  (2,  i,  j)  -si  j  (2,i,  j)+a2  ( ( j-1)  *nbas+k)  *a3  ( (i-1)  *nbas+k) 

c  spin  up  aij  now 

do  805  i-l,nup 
do  805  j-l,nup 
aij  (1, i, j) -0. 0 
do  805  k«l,nbas 
do  805  l-l,nbas 

805  aij  (1,  i,  j)-aij  (1,  i,  j)+vxt  (k,l)  *al  ( (i-1)  *nbas+k)  * 
lal  ( (j-1) *nbas+l) 

c  spin  down  aij  now 

do  806  i-l,ndn 
do  806  j»l,ndn 
aij  (2, i, j) -0.0 
do  806  k-l,nbas 
do  806  l-l,nbas 

806  ai  j  (2,  i,  j)-ai  j  (2,i,  j)+vxt  (k,  1)  *a2  ( (i-1)  *nbas+k)  * 
la2  ( ( j-1) *nbas+l) 
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c  matrix  elements  formed,  add  to  hamiltonian 
do  807  i«l,nbas 
do  807  j-l,i 
sup-vxt (i, j) 
sdn-vxt  <i, j) 
c  form  spin  up  part 

do  808  k-l,nup 
do  808  1-1, nup 

808  sup-sup-si j (l,i,k) *si j (1,  j,l) *ai j (l,k,l) 

c  form  spin  down  part 

do  809  k-l,ndn 
do  809  1-1, ndn 

809  sdn-sdn-si j (2,i,k)*sij (2,  j,l) *ai j (2,k,l) 

c  all  hamiltonian  parts  formed,  add  to  hamiltonian 
ml2- (i-1) *nbas+ j 
m21- ( j-1 ) *nbas+i 
if  (i.eq.j)then 

a5 (ml 2) -a5 (tnl2)  +sup 
a6 (ml 2) -a6 (ml 2) +sdn 

else 

a5 (ml 2) -a5 (ml 2) +sup 
a5 (m21) -a5 (m21) +sup 
a6 (ml2) -a 6 (ml 2) +sdn 
a6 (m21)-a6(m21)+sdn 
endif 

807  continue 
800  continue 
c 

£*****************************#★**★***★******************★*************★ 

c 

c  end  of  lopas  insert 
c 

c»*****************************i>**************************************** 

c 

c  end  of  decision  loop 

c  small  integrals  will  not  be  updated  untill 
c  large  terms  are  selfconsistent 

c  at  this  point  in  the  program  the  scratch  arrays  contain 

c  al :  spin  up  input  vectors 

c  a2:  spin  down  input  vectors 

c  a3:  overlap  matrix 

c  a4:  one  electron  kinetic  +  potential  energy 

c  a5:  the  full  up  spin  hamiltonian 

c  a6:  the  full  down  spin  hamiltonian 

c  a7:  the  eigenvectors  of  the  overlap  matrix 

c  a8:  garbage  (scratch  matrix) 

c  a9:  the  eigenvalues  of  the  overlap  matrix 

c  copy  overlap  eigenvectors  into  a 8 

nn«nbas*nbas 

if (norm.  eq.0. and. nup. eq. ndn) then 

do  3000  i*l,nn 

a6(i)-a5(i) 

3000  continue 
endif 

do  700  k»l,nn 
700  a8(k)-a7(k) 

c  diagonalize  spin  up  hamiltonian 

call  xroot (nbas,a5,a9,a8,  rr,b, workl, work2) 
call  norms (nbas) 

don't  reverse  the  order  of  the  eigenvalues  and  eigenvectors 
copy  eigenvectors  from  b  to  a  and  a5  and  eigenvalues  from 
rr  to  ss  and  e 
k-0 


c 

c 
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do  63  i*l,nbas 

ss(i)«rr(i) 

e(l,i)-rr(i) 

do  63  j«l,nbas 

k-k+1 

a5(k)«b(k) 

63  a(k)«b(k) 

c  depopulate  desired  orbitals 

if (norm.eq. 0)  go  to  66 
if (norm.eq. 1) go  to  605 
if (iusen.ne.O)go  to  605 
call  rover (0,nbas,nup) 

605  ii-0 

11- 0 

12- 0 

do  64  i*l,nnn 
64  a(i)“0.0 

do  67  i*l,nbas 

if (iup(i) .eq.0)go  to  675 

ii«ii+l 

e (1,  ii) *rr (i) 

do  68  j-l,nbas 

68  a ( (ii-1) *nbas+j)«b( (i— 1 > *nbas+ j) 

go  to  67 

675  if (ii.lt. nup) go  to  688 
e(l,i)-rr(i) 

do  676  jj-l,nbas 

676  a ( (i-1) *nbas+j j) -b ( (i-1) *nbas+ j j) 
go  to  67 

688  i2»i2+l 

sav (i2)*i 
67  continue 

if  (ii.lt. nup)  stop  'core  orbital  deleted  and  not  replaced.' 

if (i2 .eq. 0) go  to  66 

do  677  i3-l,i2 

i4»sav (i3) 

k9«nup+i3 

e(l,k9)«rr(i4) 

do  677  jj«l,nbas 

677  a( (k9-l) *nba3+ j j) -b( (i4-l) *nbas+ j j) 

66  id20-l 

call  srtovp(al,a,e,l,istovp) 

c  new  vectors  equal  weighted  average  of  new  computed 

c  vectors  and  old  vectors 

do  56  i*l,nbas 
ml2«  (i-1) *nbas 
kl«ml2+nbas 

if  (fracn.eq.1.0)  goto  502 
do  55  j**l,nbas 
kl«ml2+ j 

55  a (kl) -a (kl) *f racn+ (1 . -f racn) *al  (kl) 

c  normalize  "total"  spin  up  vectors 

ml5«ml2+l 

call  gdotpr  (a  (ml5) ,  a3,  a  (ml 5) ,  0,  sum,  nbas) 
sum-dsqrt (sum) 
do  1024  j-l,nbas 
k2-ml2+j 

1024  a(k2)-a(k2)/sum 

502  il-ml2+l 

write  (20, rec-id20) (a (11),  ll“il,kl) 

56  id20«id20+l 

call  sqdif (nup, al,a, workl, work2, squp) 

nn-nbas*nbas 

do  504  k*l,nn 

Tbb 
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504  al(k)-a(k) 

sqdn-0 . 

if(ndn.eq.O)  go  to  90 
c  copy  overlap  eigenvectors  into  a8 

do  81  k-l,nn 
81  a8(k)-a7(k) 

c  diagonalize  spin  down  hamiltonian 

call  xroot (nbas, a6, a9, a8, rr, b,  workl, work2) 
call  norms (nbas) 

c  don't  reverse  the  order  of  the  eigenvectors  and  eigenvalues 

c  copy  eigenvectors  from  b  to  a  and  a6  and  eigenvalues  from 

c  rr  to  e 

c  note  values  in  rr  must  be  preserved  for  file  30 

k-0 

do  7  3  i-1, nbas 
e (2, i) «rr  (i) 
do  73  j»l,nbas 
k-k+1 
a6(k)=b(k) 

73  a  (k)  -b(k) 

c  depopulate  desired  orbitals 

if  (norm.eq.O)go  to  76 
if (norm.eq.l)go  to  705 
if (idsen.ne.O)go  to  705 
call  rover (1, nbas, ndn) 

705  ii-0 

11- 0 

12- 0 

do  74  i«l,nnn 
74  a (i) -0.0 

do  77  i-l,nbas 

if (idn(i) .eq.0)go  to  775 

ii«ii+l 

e (2, ii) -rr  (i) 

do  78  j-l,nbas 

78  a  ( (ii-1) *nbas+ j)-b( (i-1) *nbas+j) 

go  to  77 

775  if  (ii.lt. ndn) go  to  778 
e  (2, i)-rr (i) 

do  776  jj-l,nbas 

776  a ( (i-l)*nbas+j j)-b( (i-1) *nbas+j j) 
go  to  77 

778  i2«i2+l 

sav  (i2)-i 
77  continue 

if  (ii.lt. ndn)  stop  'core  orbital  deleted  and  not  replaced.' 

if  (i2.eq.0)go  to  76 

do  777  13-1, i2 

i4-sav(i3) 

k9«ndn+i3 

e(2,k9)-rr(i4) 

do  777  jj-l,nbas 

777  a ( (k9-l) *nbas+ j j) -b( (i4-l) *nbas+ j j) 

76  id20-181 

call  srtovp(a2, a, e, 2, istovp) 

c  new  vectors  equal  weighted  average  of  new  computed 

c  vectors  and  old  vectors 

do  87  i-1, nbas 
ml  2- (i-1) *nbas 
kl-ml2+nbas 

if  (fracn.eq.1.0)  goto  503 

do  86  j-l,nbas 

kl-ml2+j 

86  a (kl) «fracn*a (kl)  +  (l.-f racn) *a2  (kl) 
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c  normalize  "total"  spin  down  vectors 

ml5-ml2+l 

call  gdotpr (a (ml5) , a3, a (ml5) ,  0, sum, nbas) 
sum-sqrt (sum) 
do  501  j-1, nbas 
k2-ml2+j 

501  a (k2) -a (k2) /sum 

503  ml4-ml2+l 

write (20, rec-id20)  (a(l),  l«ml4,kl) 

87  id20-id20+l 

call  sqdif  (ndn,a2,a,workl,wor)c2,  sqdn) 
nn-nbas*nbas 
do  505  k-l,nn 
505  a2(k)=a(k) 

c  write  out  data  of  interest  for  each  iteration 

90  eto-etn 

call  et (etn, nup, ndn) 
edif=dabs (etn-eto) 
sqdf-squp+sqdn 
write (60, 19) iter 
print  19, iter 
write (60, 18) edif , sqdf 
print  18, edif, sqdf 
write (60, 245) etn 
print  245, etn 

c  if  convergence  has  not  occurred,  return  to  beginning  of 

c  iteration  loop 

if  (isqd.eq. 1)  edif-sqdf 
if (edif .gt.tol)  go  to  1000 
c  test  other  factors  of  selfconsistncy  here 
c  if (iter.gt.l)then 

c  iter-0 

c  go  to  1000 

c  endif 

c  end  of  extended  convergence  test 
write  (60, 12) 
print  12 
go  to  1002 

1001  write (60, 13) 

1002  write(60,14) 
write (60, 17)etn 

c  compute  and  write  spin 

c  use  a?  as  a  scratch  variable 

sum=C . 75*dfloat (nup+ndn) +0 . 25*df loat (nup* (nup-1) +ndn* (ndn-1) ) 
1  -0.5*dfloat (nup*ndn) 
do  620  i«l,nup 
ii» (i-1) *nbas 
do  620  1-1, nbas 
il-ii+1 
11- (1 -1 ) *nbas 
y-0 . 0 

do  610  k-l,nbas 
ik-ii+k 
lk-ll+k 

610  y-y+a3 (lk) *al (ik) 

620  a8(il)-y 

suml=0 . 0 
do  720  i-1, nup 
ii- (i -1) *nbas 
do  720  j-1 , ndn 
jj— (j-1) *nbas 
y-0.0 

do  730  1-1, nbas 
il-ii+1 
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730  y-y+a2(;jl)*a8(il) 

720  suml»suml+y*y 

sum-sum-suml 
spin=0 . 

if  (sum.gt . -0 . 25)  spin-dsqrt (0 . 25+sum)  -0 . 5 
if  (sum.gt. -0.25)  write (60, 172)  spin 
if  (sum. le. -0.25)  write (60, 173)  sum 
if  (norm.ne.2)  goto  1006 
write  (60, 901) 

write(60,8)  (iup ( j) , j-1, nbas) 
if  (ndn.ne.O)  write(60,10)  (idn ( j) , j-1, nbas) 
c  write  out  orbital  compositions 

1006  continue 

write ( 60, 260) 
do  1C 03  i-l,nup 
write (60,15)i,e(l,i) 

1003  write (60, 16)  (al ( (i-1 ) *nbas+ j) ,  j-1, nbas) 
if (icut .ne. 0) go  to  1100 

ncom=nup+l 
write (60,265) 
do  1110  i-ncom,  nbas 
write (60,15)i,e(l,i) 

1110  write (60,16) (al ( (i-1) *nbas+j) ,  j-1, nbas) 

1100  if (ndn.eq. 0)go  to  1004 

write (60,270) 
do  1C05  i-1, ndn 
write (60,15)i,e(2,i) 

1005  write (60,16) (a2 ( (i-1) *nbas+j) ,  j=l,nbas) 
if (ic  it.ne. 0)go  to  1004 
ncom-ndn+1 
write  ( 60,275) 
do  1115  i-ncom, nbas 
write (60,15)i,e(2,i) 

1105  write  (60, 16)  (a2 ( (i-1) *nbas+j) ,  j=l,nbas) 

1004  if  (i~bpt.ne.l)  goto  0909 

c  prepare  data  file  for  program  mbpt 

id30- 1 

write (30, rec-id30) ss 
id30-i: 30+1 

do  313  i-l,maxbas 

333  ss (i > =  rr (i) 

writ'  30, rec=id30) ss 
id30»i - ' 0+1 

do  3'"  i-1, nbas 
ii- (  -1) *nbas 
do  31 (  j-1, nbas 

334  ss  ( j ~a5(ii+j) 
write ( 30, rec-id30) ss 

335  id30-i-30+l 

id30- 3+nbas 
do  3 17  i-1, nbas 
ii- (  -1) *nbas 
do  311  j-l,nbas 
336  ss ( j  -a6 (ii+ j) 

writ"  30, rec*id30) ss 
337  id3Q-i  ' 0+1 
909  call  -ulpop 
goto  1000 
1054  cont.-ue 

writ  '60, 11) 
clos  unit-5) 
clos  unit-4) 
clos •  unit-20) 
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close  (unit-3) 

8765  format ( lx, f 18 . 6, 4x, fl8 . 6) 
return 
end 

subroutine  mulpop 
c  define  needed  variables 
parameter  (naxbas-180) 
parameter  (naxoc-300) 
implicit  real*8  (a-h,o-z) 

common  /al/al  (1) /a2/a2 (l)/a3/a3(l)/ files /nbas,  ifile,  maxbas 
common  enrep, nup, ndn 

real*8  pops (naxbas,2) , opops (naxbas) ,  apops (naxoc,2) 
integer  nocc (2) , ncntr (naxbas) , kcntr (naxbas) , ktype (naxbas) 
logical  skip 

c  calculate  mullikan  populations  of  orbitals  and  atoms 
c  read  ir.  basis  set  information  for  mulpop 
rewind! 
read (4 ) 

read (4 ) nbasns,  (ndum,  ndum, ncntr (i) , ndum, kcntr (i) , ktype (i) , 
li-l,nb'  'ns) 
read ( 4 
read (4 : noc 
rewind  1 

skip- (~~d (nbas, 10) .eq.O) 
do  29210  il-1,2 
do  1011  i»l,nbas 
1010  pops (i, il) -0 .d0 
nocc (il) -nup 
if(il.eq.2)  nocc(il)-ndn 
if (nocc (il) .eq. 0)  go  to  29290 
do  6060  ic-1, nocc  (il) 
do  1111  i«l,nbas 
1111  opops (i) =0 .d0 
ii-0 

do  5050  i»l,nbas 

tiic-al ( (ic-1) *nbas+i) 

if (il . eq. 2)  tiic-a2 ( (ic-1 ) *nbas+i) 

if (tiic.eq. 0 .d0)  go  to  5050 

temp«0 .d0 

81851  format (lhO, 23x, ' 3pin  up  orbitals  only') 

81852  format (lhO, 23x, ' spin  down  orbitals  only') 
do  4040  j«l,nbas 

t jic-ai ( (ic-1) *nbas+ j) 

if (il .eq. 2)  t jic-a2 ( (ic-1) *nbas+ j) 

4040  temp»temp+tiic*t jic*a3 ( ( i — 1 ) *nbas+ j) 
opops (i) -opops (i) +temp 
5050  continue 

do  19191  i*l,nbas 

19191  pops (i, il) -pops  (i, il) +opops (i) 

6060  continue 

c  write  out  mulliken  populations  over  basis  functions 
c  in  orbital  ten  column  unit 
n-1 

write (60, 8185) 

8185  format (lh0/15x, 'mulliken  population  over  basis  functions') 
if(il.eq.2)  go  to  19196 
write (60, 81851) 
go  to  19197 

19196  write (60, 81852) 

19197  continue 

if (nbas . le. 10)  go  to  21215 
do  21210  m-10,nbas,l0 
write <60, 19190)  (i,i-n,m) 
write (60, 19200)  (kcntr (i) , i-n,m) 
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write  (60, 19210)  (ktype <i) , i«n,m) 

19190  format  (//5x, ' function' , 2x, 10 (5x, i2, 3x) ) 

19200  format (5x, f center' , 4x, 10 (5x, a4, lx) ) 

19210  format (5x, 'type' , 6x, 10 (5x,a4, lx) ) 
write (60, 20200)  (pops (i,  il) , i-n,m) 

^0200  format (5x, 'population' , 10 (2x, f 8 . 4) ) 

21210  n-m+1 

if (skip)  go  to  22220 
21215  m-nbas 

write (60, 19190)  (i,i-n,m) 
write (60, 19200)  (kcntr (i) , i«n,m) 
write (60, 19210)  (ktype (i) ,  i-n,m) 
write (60,20200)  (pops (i,  il) ,  i»n,m) 

22220  continue 

c  calculate  mulliken  populations  over  atoms 
do  23230  i*l,noc 
23230  apops (i,il)"0.d0 
do  25250  i**l,nbas 
nc»ncntr (i) 

25250  apops (nc, il) =apops (nc, il) +pops (i, il) 
c  write  out  mulliken  populations  over  atoms 
write (60,26260) 

26260  format (///5x, 'mulliken  populations  for  atoms' //5x, ' center' , 5x, 
* ' population' / ) 
do  28280  i-l,noc 
do  27270  j«l,nbas 
lcntr»kcntr ( j) 

if (ncntr ( j) .eq.ijgo  to  27275 
27270  continue 

go  to  28280 

27275  write (60,28285) lcntr, apops (i, il) 

28280  continue 

28285  format (6x,  a4, 7x,  f 8 . 4 ) 

29290  continue 

c  write  out  mulliken  populations  over  basis  functions 
c  in  orbital  ten  column  unit 

do  29295  i»l,nbas 

29295  pops (i, 1) =pops (i, 1) +pops (i, 2) 
n=l 

write (60, 8185) 
write (60, 81853) 

81853  format (lhO, 23x, ' total  populations') 
if (nbas . le . 10)  go  to  41415 
do  41410  m-10,nbas,10 
write (60, 19190)  (i,i«n,m) 
write (60, 19200)  (kcntr (i) ,  i=n,m) 
write (60, 19210)  (ktype (i) , i«n,m) 
write (60,20200)  (pops (i, 1) , i=n,m) 

41410  n»m+l 

if  (skip)  go  to  44440 
41415  m-nbas 

write (60, 19190)  (i,i*n,m) 
write (60, 19200)  (kcntr (i) ,  i-n,m) 
write (60, 19210)  (ktype (i) , i-n,m) 
write (60,20200)  (pops (i, 1) , i-n,m) 

44440  continue 

c  calculate  mulliken  populations  over  atoms 
do  43430  i-l,noc 

43430  apops (i, 1) -apops (i, 1) +apops (i, 2) 
c  write  out  mulliken  populations  over  atoms 
write (60, 26260) 
do  48480  i«l,noc 
do  47470  j«*l,nbas 
lcntr»kcntr ( j) 
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if  (ncntr ( j) .eq.i)go  to  47475 
47470  continue 

go  to  48480 

47475  write  <60, 28285) lcntr, apops (i, 1) 

48480  continue 
return 
end 

c  this  subroutine  reads  the  one  electron  integrals  and 

c  fills  the  overlap  matrix  and  the  spin  up  and  spin 

c  down  hamiltonians 

subroutine  one 

implicit  double  precision (a-h, o-z) 
integer* 2  iil (1024) , jjl (1024) , itgl {1024) 

common/ files /nbas, ifile  v 

common  enrep/al/al (D/a2/a2(l)/a3/a3(l)/a4/a4(l)/a5/a5(l)/a6/ 

1  a6  (1) /a/a (1) /b/b (1) /e/e (2, 1) /iup/iup (1) /idn/idn (1) / 

1  rr/rr (1) /sav/sav (1024) 

common/lb/ipak (1024) /inxcm/isnx (1) 

dimension  label (18) 

rewind  4 

read (4) label 

read(4)nbfn 

if (nbfn.ne.nbas)go  to  90 
read (4) 
read (4) 
read(4)enrep 
write (60, 100) label 
100  format (/18a4) 
read (4) nlab 

20  read (4) nints, last, iil, jjl, itgl, sav 

c  integrals  read  in  batches  of  1024.  nints  is  how  many  there  are  in  this  batch,  last 

i3 

c  a  sentry  for  the  last  batch,  ipak  is  the  packed  label,  sav  i3  the  integral, 

c  read  overlap  integrals  into  a3 

do  30  m-1, nints 
i-iil  (m) 

j-j jl <m> 

itag-itgl  (m) 

a3 ( (i-1) *nbas+ j) -sav (m) 

30  a3 ( ( j-1) *nbas+i) -sav (m) 

if (last . eq. 0) go  to  20 

c  read  kinetic  energy  integrals  into  a4 

read (4) nlab 

35  read (4) nints, last, iil, j  jl, itgl, sav 

do  40  m-1, nints 
i-iil (m) 
j-jjl(m) 
itag-itgl (m) 
a4 ( (i-1) *nbas+ j) -sav (m) 

40  a4 ( ( j-1) *nbas+i) -sav (m) 

if (last . eq. 0) go  to  35 

c  read  potential  energy  integrals  and  add  them  into  a4 

read (4) nlab 

45  read (4) nints, last, iil, jjl, itgl, sav 

do  50  m-1, nints 
i-iil (m) 
j-j jl  (m) 
itag-itgl (m) 
k5- (i-1) *nbas+ j 
a4  (k5)  «a4  (k5)  +sav  (m) 

50  a4 ( ( j-1) *nbas+i) -a4 (k5) 

if (last.eq.O)go  to  45 
return 

write (60,120) nbfn, nbas 
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120  format  (115x, '  nbf  from  tape:',i.3,'  not  equal  to  nbf  input  :',i3) 
stop 
end 

c  this  subroutine  normalizes  the  orbital  vectors 

subroutine  norms  (nbas) 
implicit  double  precision  (a-h,o-z) 
common/a/a (1) /b/b(l) /al/al(l)/a2/a2(l)/a3/a3(l)/ 

1  a4/a4(l)/a5/a5(l)/a6/a6(l) 

do  2  i-1, nbas 
ml  2- (i-1 ) *nbas 
ml5-ml2+l 

call  gdotpr (b (ml 5) ,  a3,  b (ml 5) , 0 , sum, nbas) 

3um=dsqrt (sum) 
do  2  j»l,nbas 
k2-ml2+ j 

2  b(k2) «b(k2) /sum 

return 
end 

c  this  subroutine  identifies  the  core  orbital 

c  to  be  depopulated 

subroutine  rover (il, nbas, n) 
implicit  double  precision  (a-h,o-z) 

common/iup/iup (1) /idn/idn (1 ) /holdup/holdup (1) /holddn/holddn (1) / 

1  hold/hold (1) /a3/a3 (1) /rovr/rovr (1) /a/a (1) 
if (il .eq. 1) go  to  3 
do  2  j 1*1, nbas 
2  hold( jl) -holdup < jl) 

go  to  5 

do  4  jl=l,nbas 
hold( jl)«holddn( jl) 
continue 
do  6  i-1, nbas 
ini- (i-1 ) *nbas+l 
6  call  gdotpr (hold, a3, a (ini ),  0,  rovr (i) , nbas) 

omax-0 . 0 
do  10  i-1, nbas 
tst-dabs (rovr  (i) ) 
if (tst .gt . omax) ielim=i 
if (tst .gt . omax) omax-tst 
10  continue 

if (il .ne. 0) go  to  20 
do  15  i-1, nbas 

15  iup(i)-0 

do  16  i-l,n 

16  iup(i)«l 
iup (ielim) -0 

if (ielim. le . n) iup (n+1) -1 
go  to  40 

20  do  25  i-1, nbas 

25  idn(i)«0 

do  26  i-l,n 

26  idn(i)«l 
idn (ielim) -0 

if  (ielim. le. n) idn (n+1 ) -1 
40  return 

end 

c  this  subroutine  calculates  the  sum  of  the  squares 

c  of  the  differences  of  the  eigenvectors  for  a  test 

c  of  convergence 

c  description  of  parameters 

c  n  number  of  occupied  orbitals  in  this  spin  state 

c  vecto  -  matrix  of  old  eigenvectors 

c  vectn  -  matrix  of  current  eigenvectors 

c  sq  returned  sum  of  squares  of  the  differences  of 
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c  the  n  occupied  orbitals  in  this  spin  state 

subroutine  sqdif (n, vecto,  vectn,  workl, work2, sq) 
implicit  double  precision  (a-h,o-z) 
common  /files/nbas, ifile,maxbas/a3/a3 
dimension  a3 (1) ,vecto(l) ,vectn(l> , world  (1) , work2 (1) 
sq-0 . 

do  20  i*l,n 
ii« ( i — 1 ) *nbas 
do  10  j-l,nbas 

10  workl (j) -vecto (ii+ j) -vectn (ii+j) 

call  gdotpr (workl , a3, workl, work2, temp, nbas) 

20  sq-sq+temp 

return 
end 

c  if  istovp-l  is  specified,  this  subroutine  sorts  the  current 

c  iteration  eigenvectors  so  that  the  overlap  with  the  corresponding 

c  eigenvector  of  the  previous  iteration  is  a  maximum, 
c  sorting  is  done  using  a  row  pivoting  strategy  on  the 
c  implicitly  constructed  matrix  of  overlaps, 

c  this  subroutine  always  adjusts  the  current  eigenvectors 

c  so  that  they  have  the  same  phase  as  the  corresponding 
c  eigenvector  of  the  previous  iteration. 

subroutine  srtovp (vecto, vectn, values, ispin, istovp) 

implicit  double  precision  (a-h,o-z) 

common  /a3/a3 (1) /files/nbas, ifile,maxbas 

dimension  vecto (1) , vectn (1) , values (2, 1) 

do  100  i-l,nbas 

ii= ( i— 1 ) *nbas 

iil-ii+1 

call  gdotpr (vecto (iil) , a3, vectn (iil) , 0,tmax,nbas) 

if  (i3tovp.ne.l)  goto  50 

imax«*i 

il=i+l 

do  30  j«il,nbas 
j j* ( j-1) *nbas 
jjl=jj+l 

call  gdotpr (vecto (iil) ,a3, vectn (jjl) , 0, temp, nbas) 
if  (dab3 (temp) . le. dabs (tmax) )  goto  30 
tmax-temp 
imax- j 

30  continue 

if  (imax.eq.i)  goto  50 
iimax- (imax-1 ) *nbas 
do  40  j»l,nbas 
temp-vectn (ii+j) 
vectn (ii+j) -vectn (iimax+j) 

40  vectn (iimax+j) -temp 

i0«i 

temp-values (ispin, iO) 
values (ispin, iO) -values (ispin, imax) 
values (ispin,  imax) -temp 
50  continue 

if  (tmax.gt.0.)  goto  100 
do  60  j»l,nbas 

60  vectn (ii+j) --vectn  (ii+j) 

100  continue 

return 
end 

c  this  subroutine  computes  the  generalized  dot  product  of  vectors 
c  x  and  y  with  respect  to  the  metric  tensor  a, 

c  description  of  parameters: 

c  x  -  left  input  vector  (n) 

c  a  -  metric  tensor  (n*n) 

c  y  right  input  vector  (n) 

2-  3y 
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c  work  -  scratch  vector  (n) 

c  (not  needed  this  version,  specify  as  0) 

c  value  -  returned  value  of  the  dot  product, 

c  n  length  of  each  vector, 

c  x  and  y  need  not  be  distinct. 

subroutine  gdotpr (x, a, y, work, value, n) 
real* 8  x(l),a(l),y(l),work(l) , value 
value**0 . 
do  100  j-l,n 
j j-( j-1) *n 
do  100  i«l,n 

100  value*value+x (i) *a ( j j+i) *y ( j) 
return 
end 

c  this  subroutine  evaluates  the  total  energy 

subroutine  et (etn, nup, ndn) 
implicit  double  precision  (a-h,o-z) 
common/f ile3/nbas, if ile,maxbas 

common  enrep/a/a (1) /b/b(l) /e/e (2, 1) /iup/iup (1) /idn/ 

1  idn (1) /rr/rr(l) /sav/sav (1024) /al/al (1) /a2/a2 (1) /a3/a3 (1) /a4/ 

1  a4(l)/a5/a5(l)/a6/a6(l) 

etn»0 . 0 
do  1  i«l,nup 

1  etn»etn+e (1, i) 

if(ndn.eq.O)  go  to  2 

do  3  i»l,ndn 

3  etn*etn+e (2, i) 

2  continue 

do  14  i»l,nup 
ml5=»  (i-1) *nbas+l 

call  gdotpr(al (ml5) ,a4,al (ml5) ,0,3,nbas) 

14  etn-etn+s 

if (ndn.eq. 0) go  to  16 
do  17  i-l,ndn 
ml  5- (i-1) *nbas+l 

call  gdotpr (a2 (ml 5) , a4 , a2 (ml 5) ,0, s, nbas) 

17  etn=*etn+s 

16  etn*etn/2 . 0+enrep 
return 
end 

c  this  subroutine  adds  the  integrals  into  the 

c  spin-up/spin-down  hamiltonians 

subroutine  two 

implicit  double  precision (a-h, o-z) 

integer*2  mul (1024) ,iil (1024) , jjl (1024) , kkl (1024) ,111 (1024) 

1, itgl (1024) 

common/f iles/nbas, if ile, maxbas 
common/inxcm/isnx (1) 

common  enrep, nup, ndn/a/a (1) /b/b (l)/e/e(2,l) /iup/ 

1  iup (1) /idn/ idn (1) / rr/rr (1) /sav/sav (1024) /hu/hu (1) / 

1  hd/hd(l) /al/al (1) /a2/a2 (1) /a3/a3 (1) /a4/a4 (1 ) /a5/a5 (1 ) / 

1  a6/a6 (1) 

dimension  saver (1024) 
common/ lb/ ipak (1024) 

c  if  using  combined  integrals-labels  tape  nints-number  of  integrals=number  of  labels 

c  if  using  separate  integrals  and  labels  tapes  nintl=number  of  integrals, 

c  nints^number  of  labels 

c  rewind  and  position  tapes  3  and  4 

rewind  4 
read (4) label 
read(4) nbfn 
read (4) 
read (4) 
read (4) enrep 
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206 

100 


201 

200 

2001 

c 


4 
6 

c 

5 


40 

9 


1 

8 


7 

2 


72 


c 

2013 

c 

2015 


do  100  ict-1,3 

read (4) nlab 

read (4) nints,  last 

if (last.eq.O)go  to  206 

continue 

if (ifile.ne.l)go  to  2001 
rewind  3 
read (4) nlabl 

read (4) nintl, lastl, saver 

read (3) 

read (3) 

do  200  i*l,3 

read (3) 

read (3) ilab, ifml 

if (ifml.eq.O)go  to  201 

continue 

continue 

put  up  spin  rho  into  a,  down  spin  rho  into  b 
if (ndn.eq.O)go  to  5 
do  6  i-l,nbas 
do  6  j-l,nbas 
k21»(i-l) *nbas+ j 
a  (k21) -0 . 0 
b(k21)-0.0 
do  4  k-1, nup 

a (k21) -a (k21) +al ( (k-1) *nbas+i) *al ( (k-1) *nbas+ j) 
do  6  k-l,ndn 

b<k21)-b(k21)+a2 ( (k-1) *nbas+i) *a2 ( (k-1) *nbas+ j) 
go  to  9 

case  of  no  down  spin  electrons 
do  40  i«l,nbas 
do  40  j*l, nbas 
k21« (i-1) *nbas+ j 
a (k21) -0 . 0 
do  40  k-1 , nup 

a (k21) -a (k21) +al ( (k-1 ) *nbas+i) *al ( (k-1) *nbas+ j) 

k- (maxbas+1) *maxbas/2 

do  1  i«l,k 

hu (i) »0 . 0 

hd(i)-0.0 

if (ndn.ne.O)go  to  2 

k«maxbas*maxbas 

do  7  i*l,k 

b (i) «0 . 0 

continue 

intwh-0 

if (ifile.ne.l) read (4) nlab 
if  (ifile.ne.0)  read(3)nlab 

if  (ifile.ne.0)  read (3) nints,  last,  iil,  jjl,  kkl, 111, itgl,mul 

if (ifile.ne.l) read (4) nints, last,  iil,  jjl,  kkl, 111, itgl,mul, saver 
if (nints . eq. 0) go  to  30 
do  29  ml**l, nints 
i-iil (ml) 
j-jjl(ml) 
k-kkl (ml) 

1-111 (ml) 
itag-itgl (ml) 
mu-mu 1 (ml) 

if (itag-1) 2017, 2013, 2015 
old  integral 
aint-xint 
go  to  2031 

negative  of  old  integral 
aint— xint 
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go  to  2031 

new  integral  required 
if (ifile) 2018, 2020, 2018 
intwh-ml 
xint-saver (ml) 
aint-xint 
go  to  2031 
intwh-intwh+1 

if (intwh-nintl) 2021,2021, 2019 
xint-saver (intwh) 
aint-xint 
go  to  2031 

if (lastl .ne. 0) stop' not  enough  unique  integrals/ 
too  many  labels' 
intwh-1 

read(4) nintl, lastl, saver 
xint-saver (1) 
aint-xint 
2031  continue 

taint-aint+aint 

if (mu. It . 1 . or .mu.gt . 14)  go  to  1999  • 
mu* 15 -mu 

go  to  (25,24,23,22,21,20,19,18,17,16,15,14,13,12) , mu 
c  iiii 

12  ii-isnx(i)+i 
nii* (i-1 ) *nbas+i 

hu (ii) -hu (ii) +aint*b (nii) 
hd(ii) -hd(ii) +aint*a (nii) 
go  to  29 
c  ijij 

13  ij*isnx(i)+j 
ii*isnx (i) +i 
j j-isnx( j)+j 

ni j- (i-1) *nbas+ j 
nj j*( j-1) *nbas+j 
nii- (i-1 ) *nbas+i 

hu (i j) =hu (i j) +aint* (a (ni j) +2 . 0*b (ni j) ) 
hu (ii) -hu (ii) -aint*a (nj j) 
hu ( j j) -hu ( j j) -aint*a (nii) 
hd(i j) «hd(i j) +aint* (b (ni j ) +2 . 0*a (ni j) ) 
hd(ii)-hd(ii) -aint*b(nj j) 
hd( j j) -hd( j j) -aint*b(nii) 
go  to  29 
c  ii  j  j 

14  ii-isnx(i)+i 
kk-isnx (k) +k 
ik-isnx (i) +k 
nkk- (k-1 ) *nbas+k 
nii- (i-1) *nbas+i 
nik- (i-1 ) *nbas+k 

hu (ii) -hu (ii) +aint* (a (nkk) +b (nkk) ) 
hd(ii)-hd(ii)+aint* (a (nkk) +b (nkk) ) 
hu (kk) -hu (kk) +aint* (a (nii) +b (nii) ) 
hd(kk) -hd(kk) +aint* (a (nii) +b (nii) ) 
hu (ik) -hu (ik) -aint*a (nik) 
hd(ik) -hd(ik) -aint*b(nik) 
go  to  29 
c  iiil 

15  il-isnx(i)+l 
ii-isnx (i) +i 
nii- (i-1) *nbas+i 
nil- (i-1) *nbas+l 

hu (il) -hu (il) +aint*b(nii) 
hd(il) -hd(il) +aint*a (nii) 

7.3? 


c 

2017 

2020 


2018 

2021 


2019 
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hu (ii) “hu (ii) +taint*b (nil) 
hd(ii) -hd(ii) +taint*a (nil) 
go  to  29 

c  iikl 

16  kl-ianx (k) +1 
ii-isnx (i) +i 
il-isnx (i)+l 
ik“isnx (i) +k 
nii- (i-1) *nbas+i 
nkl- (k-1) *nbas+l 
nik- (i-1) *nbas+k 
nil- (i-1) *nbas+l 

hu (kl) «hu (kl) +aint* (a (nii) +b  (nii) ) 
hu (ii) -hu (ii) +taint* (a (nkl) +b (nkl) ) 
hu (il) “hu (il) -aint*a (nik) 
hu (ik) “hu (ik) -aint*a (nil) 
hd(kl)“hd(kl)+aint* (b(nii)+a (nii) ) 
hd(ii) “hd(ii) +taint* (b (nkl) +a  (nkl) ) 
hd(il) “hd(il) -aint*b(nik) 
hd(ik) “hd(ik) -aint*b(nil) 
go  to  29 
c  ij  j  j 

17  j j“isnx( j)+j 
i j“isnx (i) + j 

ni j- (i-1) *nbaa+ j 
n j  j— { j— 1 ) *nbas+j 
hu ( j j) -hu ( j j) +taint*b (ni j) 
hd( j j) -hd( j j) +taint*a (ni j) 
hu (i j) «hu (i j) +aint*b(n j j) 
hd (i j) -hd(i j) +aint*a (nj j) 
go  to  29 

c  i jkk, j  gt  k 

18  kk“ianx(k)+k 
i j“ianx (i) + j 
jk“isnx ( j) +k 
ik“ianx (i) +k 

ni j“ (i-1) *nbas+ j 
nkk- (k-1) *nbas+k 
n jk- ( j-1) *nbas+k 
nik-  (i-1) *nbas+k 

hu (kk) -hu (kk) +taint* (a (ni j) +b  (ni j) ) 
hu (i j) “hu (i j) +aint* (a (nkk) +b (nkk) ) 
hu (ik) »hu (ik) -aint*a (n jk) 
hu ( jk) *hu ( jk) -aint*a (nik) 
hd(kk) -hd(kk) +taint* (b (ni j) +a (ni j) ) 
hd(i j) “hd (i j) +aint* (b (nkk) +a (nkk) ) 
hd(ik)*hd(ik) -aint*b(njk) 
hd( jk) “hd( jk) -aint*b(nik) 
go  to  29 

c  ijkk  j  It  k 

19  kk»isnx(k)+k 
i j-isnx (i) + j 
jk“isnx (k) + j 
ik“isnx  (i) +k 

ni j- (i-1) *nbas+ j 
nkk« (k-1 ) *nbas+k. 
njk“( j-1) *nbas+k 
nik“ (i-1) *nbas+k 

hu (kk) “hu (kk) +taint* (a (ni j) +b (ni j) ) 
hu (i j) “hu (i j) +aint* (a (nkk) +b (nkk) ) 
hu (ik) “hu(ik) -aint*a (njk) 
hu ( jk) -hu ( jk) -aint*a (nik) 
hd(kk) *hd(kk) +taint* (b(ni j) +a (ni j) ) 
hd (i j ) -hd (i j ) +aint* (b (nkk) +a (nkk) ) 


n  *2,  ft 
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hd(ik)-hd(ik)-aint*b(njk) 
hd< jk)-hd< jk)-aint*b(nik) 
go  to  29 
c  ij  jl 

20  ij-ianx(i)+j 
jl«isnx(j)+l 
j j-isnx(j)+j 
il-ianx (i) +1 
njl«( j-1) *nbaa+l 
ni j-(i-l) *nbaa+ j 
nil* (i-1) *nbaa+l 
nj j* ( j-1) *nbaa+ j 

Hu  (i  j)  -hu  (i  j)  +aint*  (a  (n  jl)  +2 . 0*b  (n  jl) ) 
hu ( jl) -hu ( jl) +aint*  (a  {ni  j)  +2 . 0*b  (ni  j)  ) 
hu( j j)-hu( j j) -taint *a (nil) 
hu (il) *hu (il) -aint*a (n j  j ) 
hd(i j) -hd(i j) +aint* (b (n jl) +2 . 0*a (n jl) ) 
hd( jl) -hd( jl) +aint* (b (ni  j) +2 . 0*a  (ni  j) ) 
hd( j j)»hd( j j) -taint*b(nil) 
hd(il) *hd(il) -aint*b (n j j) 
go  to  29 
c  i  jil 

21  il*isnx(i)+l 
i j*isnx (i) + j 
ii*isnx (i) +i 
jl-ianx( j)+l 
nil* (i-1) *nbaa+l 
ni j* (i-1) *nbaa+ j 
n jl- ( j-1) *nbaa+l 
nii* (i-1) *nbas+i 

hu(ij)-hu(i j)+aint* (a (nil) +2 . 0*b (nil) ) 
hu (il) *hu (il) +aint* (a (ni j) +2 . 0*b (ni j) ) 
hu (ii) -hu (ii) -taint *a  (n jl) 
hu ( jl) -hu ( jl) -aint*a (nii) 
hd(i j) -hd(i j) +aint* (b(nil) +2 . 0*a (nil) ) 
hd(il)-hd(il)+aint* (b(ni j) +2. 0*a (ni j) ) 
hd(ii)-hd(ii) -taint*b (n jl) 
hd( jl) -hd( jl) -aint*b (nii) 
go  to  29 
c  ijkj 

22  ij-isnx(i)+j 
k j-ianx (k) + j 
j j-ianx( j)+j 
ik-ianx (i) +k 

nk j- (k-1) *nbaa+ j 
ni j- (i-1) *nbaa+ j 
nik- (i-1) *nbaa+k 
n j  j—  <  j — 1 ) *nbaa+j 

hu (i j) -hu (i j) +aint* (a (nk j) +2 . 0*b (nk j) ) 

hu (k j) -hu (k j) +aint* (a (ni j) +2 . 0*b (ni j) ) 

hu ( j j) -hu ( j j) -taint *a (nik) 

hu (ik) -hu (ik) -aint*a (n j j) 

hd(i j) -hd(i j) +aint* (b (nk j) +2 . 0*a (nk j ) ) 

hd(k j) -hd(kj) +aint* (b (ni j) +2 . 0*a (ni j) ) 

hd( j j) -hd( j j) -taint *b (nik) 

hd (ik) -hd(ik) -aint*b (n j j) 

go  to  29 

c  ijkl  j.gt.k, j.gt.l 

23  kl-ianx (k) +1 
jk-ianx(  j)+k 
jl-isnx( j)+l 
i j-ianx (i) + j 
il-ianx (i) +1 
ik-ianx (i) +k 
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nkl- (k-1 ) *nbaa+l 
ni j- ( i — 1 ) *nbas+ j 
njl-(j-l)*nbaa+l 
nik-(i-l) *nbas+k 
nil**  ( i — 1  >  *nbaa+l 
njk-( j-1) *nbas+k 

hu (i j) -hu (i j) +taint* (a (nkl) +b (nkl) ) 

hu  (kl)  -hu  <kl)  +taint*  (a  (ni  j)  +b  (ni  j) ) 

hu (ik) -hu (ik) -aint*a (n jl) 

hu( jl)-hu( jl) -aint*a (nik) 

hu( jk)-hu( jk) -aint*a(nil) 

hu (il) -hu (il) -aint*a (n jk) 

hd(i j) -hd(i j) +taint* (a (nkl) +b (nkl) ) 

hd(kl) -hd(kl) +taint* (a (ni j) +b (ni j) ) 

hd(ik) -hd(ik) -aint*b (n jl) 

hd( jl)-hd( jl) -aint*b(nik) 

hd( jk) «hd( jk) -aint*b (nil) 

hd (il) -hd (il) -aint*b (n jk) 

go  to  29 

c  ijkl  j . It . k, j .gt . 1 

24  kl-isnx(k)+l 
jk-isnx (k) + j 
jl-ianx ( j) +1 
i j-isnx (i) + j 
il-isnx (i) +1 
ik-isnx(i)+k 
nkl- (k-1) *nbaa+l 
ni j- (i-1) *nbaa+ j 
njl- ( j-1) *nbaa+l 
nik- (i-1) *nbaa+k 
nil* (i-1) *nbaa+l 
njk-( j-1) *nbaa+k 

hu (i j) -hu (i j) +taint* (a (nkl) +b (nkl) ) 

hu  (kl)  -hu  (kl)  +taint*  (a  (ni  j)  +b  (ni  j) ) 

hu (ik) -hu (ik) -aint*a (njl) 

hu ( jl) -hu ( jl) -aint*a (nik) 

hu ( jk) -hu ( jk) -aint*a (nil) 

hu (il) -hu (il) -aint*a (n jk) 

hd(i j) -hd(i j) +taint* (a (nkl) +b (nkl) ) 

hd(kl) -hd(kl) +taint* (a (ni j) +b (ni j) ) 

hd(ik) -hd(ik) -aint*b (njl) 

hd( jl) -hd( jl) -aint*b (nik) 

hd( jk) -hd( jk) -aint*b (nil) 

hd (il) -hd (il) -aint*b (n jk) 

go  to  29 

c  ijkl  j  .  It . k, j . It .  1 

25  kl-ianx (k) +1 
jk-isnx (k) + j 
jl-ianx  (1) + j 
i j-ianx (i) + j 
il-isnx (i) +1 
ik-ianx (i) +k 
nkl- (k-1) *nbas+l 
ni j- (i-1) *nbas+ j 
n jl- ( j-1) *nbaa+l 
nik- (i-1) *nbas+k 
nil- (i-1) *nbas+l 
n jk- ( j-1) *nbas+k 

hu  (i  j)  -hu  (i  j)  +taint*  (a  (nkl)  +b  (nkl) ) 
hu (kl) -hu (kl) +taint* (a (ni j) +b (ni  j) ) 
hu (ik) -hu (ik) -aint*a (njl) 
hu ( jl) -hu ( jl) -aint*a (nik) 
hu ( jk) -hu ( jk) -aint*a (nil) 
hu (il) -hu (il) -aint*a (n jk) 


n  KiO 


lopas . sub 


Fri  Apr  5  11:22:53  1991 


163 


hd{i j) -hd(i j) +taint* (a (nkl) +b (nkl) ) 
hd(kl) -hd(kl) +taint* (a (ni j) +b (ni j) ) 
hd(ik)-hd(ik) -aint*b(njl) 
hd( jl)“hd( jl) -aint*b(nik) 
hd( jk) -hd( jk) -aint*b(nil) 
hd(il) -hd(il) -aint*b(njk) 

29  continue 

30  if (last .eq. 0) go  to  72 
do  31  i-l,nbas 

do  31  j-l,i 
indh**isnx  (i)  +  j 
k6*( j-1) *nbas+i 
k7» (i-1) *nbas+ j 
a5 (k6) «hu (indh) 
a5 (k7) *hu (indh) 
a6 (k6) “hd(indh) 

31  a6(k7)«hd(indh) 
do  33  i*l,nba3 
do  33  j»l,nbas 
k6» (i-1 ) *nbas+ j 

a5 <k6)»a5 (k6)+a4 (k6) 
a6 (k6) -a6 (k6) +a4 (k6) 

33  continue 
return 

1999  write(60, 502)mu 

502  format  ('  mu  out  of  range  in  subroutine  two  mu  «',i4) 
end 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


subroutine  xroot  —  this  subroutine  is  a  modified  version  of  nroot 
purpose 

compute  eigenvalues  and  eigenvectors  of  a  real  nonsymmetric 
matrix  of  the  form  b-inverse  times  a.  this  subroutine  is 
normally  called  by  subroutine  canor  in  performing  a 
canonical  correlation  analysis. 

usage 

call  xroot  (m,a,bl,bx,xl,x,workl,work2) 

description  of  parameters 

order  of  square  matrices  a,  b,  bx,  and  x. 
input  matrix  (m  x  m)  (full  matrix,  destroyed) . 
input  vector  of  length  m  containing  eigenvalues 
of  b. 

input  matrix  (m  x  m)  containing  eigenvectors 
of  b  (destroyed) . 

output  vector  of  length  m  containing  eigenvalues  of 
b-inverse  times  a. 

output  matrix  (m  x  m)  containing  eigenvectors  column¬ 
wise  of  b-inverse  times  a. 
work  vector  of  length  m. 
work2-  work  vector  of  length  m. 

remarks 

note  that  the  matrix  b  is  assumed  to  be  positive 
definite,  that  is,  each  of  its  eigenvalues  must  be 
positive. 

note  also  that  b  is  never  passed  to  this  routine, 
only  its  eigenvalues  and  eigenvectors  are  needed. 


c 

m 

c 

a 

c 

bl 

c 

c 

bx 

c 

c 

xl 

c 

c 

X 

c 

c 

workl- 

c 

work2- 

subroutines  and  function  subprograms  required 
eispack  path  rsp 
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c 

c  method 

c  refer  to  w.  w.  cooley  and  p.  r.  lohnes,  'multivariate  pro- 

c  cedurea  for  the  behavioral  aciencea',  john  wiley  and  aona, 

c  1962,  chapter  3. 

c 

c  . 

c 

subroutine  xroot  (m,a,bl,bx,xl,x, workl, work2) 
dimension  a (1) , bl (1) , bx (1) , xl (1) , x (1 ) , workl (1) , work2 (1) 
c 

c  . 

c 

c  if  a  single  precision  version  of  this  routine  is  desired,  a 

c  c  should  be  placed  in  column  1  of  the  double  precision 

c  statement  which  follows, 

c 

double  precision  a, bl, bx, xl, x,  sumv, workl, work2 
c 

c  the  c  must  also  be  placed  in  double  precision  statements 

c  appearing  in  other  routines  used  in  conjunction  with  this 

c  routine, 

c 

c  the  single  precision  version  of  this  subroutine  must  also 

c  contain  single  precision  fortran  f unctions. dsqrt  in  statements 

c  110  and  175  must  be  changed  to  sqrt.dabs  in  statement  110 

c  must  be  changed  to  abs. 

c 

c  . 

c 

c 

c  form  reciprocals  of  square  root  of  eigenvalues,  the  results 
c  are  premultiplied  by  the  associated  eigenvectors, 
c 

do  110  j-l,m 

110  xl (j)  -1 . 0 /dsqrt (dabs (bl ( j) ) ) 
k-0 

do  115  j-l,m 
do  115  i-l,m 
k=k+l 

115  x(k)«bx(k) *xl ( j) 
c 

c  form  (b** (-1/2) ) prime  *  a  *  (b**(-l/2)) 

c 

do  120  i«l,m 
n2«0 

do  120  j-l,m 
nl-m* (i-1 ) 

1-m* ( j — 1 ) +i 
bx (1) -0. 0 
do  120  k-l,m 
nl-nl+1 
n2«n2+l 

120  bx  (1)  -bx  (1)  +x  (nl)  *a  (n2) 

1-0 

do  130  j-l,m 
do  130  i-l,j 
nl-i-m 
n2-m* ( j-1) 

1-1+1 
a (1) -0.0 
do  130  k-l,m 
nl-nl+m 
n2-n2+l 
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130  a(l)-a(l)+bx(nl) *x(n2) 
c 

c  compute  eigenvalues  and  eigenvectors  of  a 
c 

ma-m* (m+1) / 2 

call  rsp (m,m, ma, a,xl, 1, bx, workl, work2, ierr) 
if  (ierr.ne.O)  stop  'trouble  with  the  eigenvalue  finder.' 
c 

c  compute  the  normalized  eigenvectors 
c 

do  150  i-l,m 
n2-0 

do  150  j«l,m 
nl-i-m 
l*m* ( j — 1 ) +i 
a (1) -0 . 0 
do  150  k=l,m 
nl-nl+m 
n2«n2+l 

150  a  (1)  -a  (1)  +x  (nl)  *bx  (n2) 

1-0 

k-0 

do  180  j-l,m 
sumv-0 . 0 
do  170  i-l,m 
1-1+1 

170  sumv-sumv+a (1) *a (1) 

175  sumv-dsqrt (sumv) 
do  180  i-l,m 
k-k+1 

180  x  (k)  -a  (k)  /sumv 
return 
end 


c  074610241 

c  - 074610242 

c  074610243 

subroutine  rsp  (nm,  n,  nv,  a,  w,  matz,  z,  fvl,  fv2,  ierr)  074610244 

c  074610245 

integer  i, j,n,nm,nv, ierr, matz  074610246 

double  precision  a (nv) , w (n) , z (nm, n) , fvl (n) , fv2  (n)  074610247 

c  074610248 

c  this  subroutine  calls  the  recommended  sequence  of  074610249 

c  subroutines  from  the  eigensystem  subroutine  package  (eispack)  07465010 

c  to  find  the  eigenvalues  and  eigenvectors  (if  desired)  07465011 

c  of  a  real  symmetric  packed  matrix.  07465012 

c  07465013 

c  on  input-  07465014 

c  07465015 

c  nm  must  be  set  to  the  row  dimension  of  the  two-dimensional  07465016 

c  array  parameters  as  declared  in  the  calling  program  07465017 

c  dimension  statement,  07465018 

c  07465019 

c  n  is  the  order  of  the  matrix  a,  07465020 

c  07465021 

c  nv  is  an  integer  variable  set  equal  to  the  07465022 

c  dimension  of  the  array  a  as  specified  for  .07465023 

c  a  in  the  calling  program,  nv  must  not  be  07465024 

c  less  than  n*(n+l)/2,  07465025 

c  07465026 

c  a  contains  the  lower  triangle  of  the  real  symmetric  07465027 

c  packed  matrix  stored  row-wise,  07465028 

c  07465029 

c  matz  is  an  integer  variable  set  equal  to  zero  if  07465030 

c  only  eigenvalues  are  desired,  otherwise  it  is  set  to  07465031 

-i  u  'b 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 


c 

c 

c 

c 


c 


c 


c 

c 

c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 


any  non-zero  integer  for  both  eigenvalues  and  eigenvectors, 
on  output - 

w  contains  the  eigenvalues  in  ascending  order, 

z  contains  the  eigenvectors  if  matz  is  not  zero, 

ierr  is  an  integer  output  variable  set  equal  to  an 
error  completion  code  described  in  section  2b  of  the 
documentation,  the  normal  completion  code  is  zero, 

fvl  and  fv2  are  temporary  storage  arrays. 

questions  and  comments  should  be  directed  to  b.  s.  garbow, 
applied  mathematics  division,  argonne  national  laboratory 


if  (n  .le.  nm)  go  to  5 
ierr  -  10  *  n 
go  to  50 

5  if  (nv  .ge.  (n  *  (n  +  1))  /  2)  go  to  10 
ierr  »  20  *  n 
go  to  50 

10  call  tred3 (n,nv, a, w, fvl, fv2) 
if  (matz  .ne.  0)  go  to  20 

**********  don't  find  eigenvalues  only  ********** 

call  tqlrat (n, w, fv2, ierr) 

stop 

**********  find  both  eigenvalues  and  eigenvectors  ********** 
20  do  40  i  -  1,  n 

do  30  j  -  1,  n 
z ( j, i)  -  0.0 
30  continue 

z  (i, i)  -1.0 
40  continue 

call  tql2 (nm,n,w, fvl, z, ierr) 
if  (ierr  .ne.  0)  go  to  50 
call  trbak.3  (nm,  n,nv,a,n,  z) 

50  return 

**********  last  card  of  rsp  ********** 
end 


subroutine  tred3 (n, nv, a, d, e,e2) 

integer  i, j,k,l,n,ii,iz, jk,nv 
double  precision  a (nv) , d(n) , e (n) , e2 (n) 
double  precision  f , g, h, hh, scale 
real  sqrt, abs, sign 

this  subroutine  is  a  translation  of  the  algol  procedure  tred3, 
num.  math.  11,  181-195(1968)  by  martin,  reinsch,  and  wilkinson. 
handbook  for  auto,  comp.,  vol . ii-linear  algebra,  212-226(1971). 

this  subroutine  reduces  a  real  symmetric  matrix,  stored  as 
a  one-dimensional  array,  to  a  symmetric  tridiagonal  matrix 
using  orthogonal  similarity  transformations. 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 


c 


c 


c 


120 

130 


140 

150 


on  input - 

n  ia  the  order  of  the  matrix, 

nv  must  be  set  to  the  dimension  of  the  array  parameter  a 
as  declared  in  the  calling  program  dimension  statement, 

a  contains  the  lower  triangle  of  the  real  symmetric 
input  matrix,  stored  row-wise  as  a  one-dimensional 
array,  in  its  first  n*(n+l)/2  positions. 

on  output - 

a  contains  information  about  the  orthogonal 
transformations  used  in  the  reduction, 

d  contains  the  diagonal  elements  of  the  tridiagonal  matrix, 

e  contains  the  subdiagonal  elements  of  the  tridiagonal 
matrix  in  its  last  n-1  positions.  e(l)  is  set  to  zero, 

e2  contains  the  squares  of  the  corresponding  elements  of  e. 
e2  may  coincide  with  e  if  the  squares  are  not  needed. 

questions  and  comments  should  be  directed  to  b.  s.  garbow, 
applied  mathematics  division,  argonne  national  laboratory 


**********  tor  i«-n  step  -1  until  1  do  --  ********** 
do  300  ii  «  1,  n 
i  -  n  +  1  -  ii 
1  -  i  -  1 
iz  -  (i  *  1)  /  2 
h  -  0.0 
3cale  *  0.0 

if  (1  .It.  1)  go  to  130 

**********  scale  row  (algol  tol  then  not  needed)  ********** 
do  120  k  «  1,  1 
iz  -  iz  +  1 
d(k)  -  a(iz) 

scale  »  scale  +  dabs(d(k)) 
continue 

if  (scale  .ne.  0.0)  go  to  140 
e (i)  -  0.0 
e2(i)  -  0.0 
go  to  290 

do  150  k  -  1,  1 

d (k)  -  d (k)  /  scale 
h  -  h  +  d(k)  *  d(k) 
continue 

e2(i)  -  scale  *  scale  *  h 
f  -  d(l) 

g  «  -dsign (dsqrt (h) , f ) 

e(i)  -  scale  *  g 

h  -  h  -  f  *  g 

d  (1)  -  f  -  g 

a(iz)  -  scale  *  d(l) 

if  (1  .eq.  1)  go  to  290 

f  -  0.0  ^ 

7^!? 
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c 

28445082 

do  240  j  -  1,  1 

28445083 

g  ■>  0.0 

28445084 

jJc  -  (j  *  (j-1))  /  2 

28445085 

c 

**********  form  element  of  a*u  ********** 

28445086 

do  180  k  -  1,  1 

28445087 

jk  ”  jk  +  1 

28445088 

if  (k  .gt.  j)  jk  -  jk  +  k  -  2 

28445089 

g  -  g  +  a(jk)  *  d(k) 

28445090 

180 

continue 

28445091 

c 

**********  form  element  of  p  ********** 

28445092 

e ( j)  -  g  /  h 

28445093 

f  -  f  +  e ( j)  *  d{ j) 

28445094 

240 

continue 

28445095 

c 

28445096 

hh  -  f  /  (h  +  h) 

28445097 

jk  »  0 

28445098 

c 

**********  form  reduced  a  ********** 

28445099 

do  260  j  ■  1,  1 

28445100 

f  -  d( j) 

28445101 

g*e(j)  -  hh  *  f 

28445102 

e(j)  *  g 

28445103 

c 

28445104 

do  260  k  -  1,  j 

28445105 

jk  -  jk  +  1 

28445106 

a ( jk)  -  a ( jk)  -  f  *  e(k)  -  g  *  d(k) 

28445107 

260 

continue 

28445108 

c 

28445109 

290 

d(i)  -  a(iz+l) 

28445110 

a  (iz+1 )  -  scale  *  dsqrt (h) 

28445111 

300 

continue 

28445112 

c 

28445113 

return 

28445114 

c 

**********  last  card  of  tred3  ********** 

28445115 

end 

28445116 

c 

902210241 

—  —  QftOOl 

c 

c 

902210243 

subroutine  tql2 (nm, n, d, e,  z,  ierr) 

902210244 

c 

902210245 

integer  i, j , k, l,m, n, ii, 11, nm, mml, ierr 

902210246 

double  precision  d  (n) ,  e  <n) ,  z  (nm,  n) 

902210247 

double  precision  b, c, f ,g, h, p, r,  s,machep 

902210248 

c 

real  sqrt, abs, sign 

902210249 

c 

90225010 

c 

this  subroutine  is  a  translation  of  the  algol  procedure  tql2. 

90225011 

c 

num.  math.  11,  293-306(1968)  by  bowdler,  martin,  reinsch,  and 

90225012 

c 

wilkinson. 

90225013 

c 

handbook  for  auto,  comp.,  vol . ii-linear  algebra,  227-240(1971). 

90225014 

c 

90225015 

c 

this  subroutine  finds  the  eigenvalues  and  eigenvectors 

90225016 

c 

of  a  symmetric  tridiagonal  matrix  by  the  ql  method. 

90225017 

c 

the  eigenvectors  of  a  full  symmetric  matrix  can  also 

90225018 

c 

be  found  if  tred2  has  been  used  to  reduce  this 

90225019 

c 

full  matrix  to  tridiagonal  form. 

90225020 

c 

90225021 

c 

on  input- 

90225022 

c 

90225023 

c 

nm  must  be  set  to  the  row  dimension  of  two-dimensional 

90225024 

c 

array  parameters  as  declared  in  the  calling  program 

90225025 

c 

dimension  statement. 

90225026 

c 

90225027 

c 

n  is  the  order  of  the  matrix. 

90225028 

c 

90225029 
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c  d  contains  the  diagonal  elements  of  the  input  matrix,  90225030 
c  90225031 
c  e  contains  the  subdiagonal  elements  of  the  input  matrix  90225032 
c  in  its  last  n-1  positions.  e(l)  is  arbitrary,  90225033 
c  90225034 
c  z  contains  the  transformation  matrix  produced  in  the  90225035 
c  reduction  by  tred2,  if  performed,  if  the  eigenvectors  90225036 
c  of  the  tridiagonal  matrix  are  desired,  z  must  contain  90225037 
c  the  identity  matrix.  90225038 
c  90225039 
c  on  output-  90225040 
c  90225041 
c  d  contains  the  eigenvalues  in  ascending  order,  if  an  90225042 
c  error  exit  is  made,  the  eigenvalues  are  correct  but  90225043 
c  unordered  for  indices  1 ■ 2, . . . , ierr-1,  90225044 
C  90225045 
c  e  has  been  destroyed,  90225046 
c  90225C47 
c  z  contains  orthonormal  eigenvectors  of  the  symmetric  90225048 
c  tridiagonal  (or  full)  matrix.  if  an  error  exit  is  made,  90225049 
c  z  contains  the  eigenvectors  associated  with  the  stored  90225050 
c  eigenvalues,  90225051 
c  90225052 
c  ierr  is  set  to  90225053 
c  zero  for  normal  return,  90225054 
c  j  if  the  j-th  eigenvalue  has  not  been  90225055 
c  determined  after  30  iterations.  90225056 
c  90225057 
c  questions  and  comments  should  be  directed  to  b.  s.  garbow,  90225058 
c  applied  mathematics  division,  argonne  national  laboratory  90225059 
c  90225060 

c  - - - 90225061 

c  90225062 
c  **********  machep  is  a  machine  dependent  parameter  specifying  90225063 
c  the  relative  precision  of  floating  point  arithmetic.  90225064 


90225065 


c 

********** 

90225066 

machep  -  2.dO*M-53) 

90225067 

c 

90225068 

ierr  -  0 

90225069 

if  (n  .eq.  1)  go  to  1001 

90225070 

c 

90225071 

do  100  i  “2,  n 

90225072 

100 

e  ( i — 1 )  -  e  (i) 

90225073 

c 

90225074 

f  -  0.0 

90225075 

b  *  0.0 

90225076 

e (n)  -  0.0 

90225077 

c 

90225078 

do  240  1  -  1,  n 

90225079 

j  -  0 

90225080 

h  -  machep  *  (dabs(d(l))  +  dabs(ed))) 

90225081 

if  (b  .It.  h)  b  -  h 

90225082 

c 

**********  look  for  small  sub-diagonal  element  ********** 

90225083 

do  110  m  ■  1,  n 

90225084 

if  (abs(e(m))  .le.  b)  go  to  120 

90225085 

c 

**********  e (n)  is  always  zero,  so  there  is  no  exit 

90225086 

c 

through  the  bottom  of  the  loop  ********** 

90225087 

110 

continue 

90225088 

c 

90225089 

120 

if  (m  .eq.  1)  go  to  220 

90225090 

130 

if  (j  .eq.  30)  go  to  1000 

90225091 

j  -  j  +  1 

90225092 

**********  form  shift  **********  90225093 

n  u7 


lopas . aub 


rri  Apr  5  11:22:53  1991 


170 


11-1+1 

90225094 

g  -  d(l) 

90225095 

p  -  (d ( 1 1 )  -  g)  /  (2.0  *  e (1) ) 

90225096 

r  -  dsqrt (p*p+l . 0) 

90225097 

d(l)  -  e(l)  /  (p  +  dsign(r,p)) 

90225098 

h  -  g  -  d(l) 

90225099 

90225100 

do  140  i  -  11,  n 

90225101 

140 

d(i)  -  d(i)  -  h 

90225102 

90225103 

f  -  f  +  h 

90225104 

**********  ql  transformation  ********** 

90225105 

p  -  d(m) 

90225106 

c  -  1.0 

90225107 

3-0.0 

90225108 

mml  -  m  -  1 

90225109 

**********  for  i=m-i  step  -1  until  1  do  —  ********** 

90225110 

do  200  ii  =  1,  mml 

90225111 

i  *  m  -  ii 

90225112 

g  -  c  *  e  (i) 

90225113 

h  -  c  *  p 

90225114 

if  (dab3(p)  .It.  dabs(e(i)))  go  to  150 

90225115 

c  -  e  (i)  /  p 

90225116 

r  -  dsqrt (c*c+l . 0) 

90225117 

e (i+1)  -  s  *  p  *  r 

90225118 

s  -  c  /  r 

90225119 

c  -  1 . 0  /  r 

90225120 

go  to  160 

90225121 

150 

c  -  p  /  e  (i) 

90225122 

r  -  sqrt (c*c+l . 0) 

90225123 

e (i+1 )  -  s  *  e  (i)  *  r 

90225124 

s  -  1.0  /  r 

90225125 

C  -  C  *  3 

90225126 

160 

p  -  c  *  d(i)  -  s  *  g 

d(i+l)  -  h  +  s  *  (c*g+s*  d(i)) 

**********  form  vector  ********** 

90225127 

do  180  k  =  1,  n 

90225130 

h  =  z (k, i+1 ) 

90225131 

z(k,i+l)  =  s  *  z(k,i)  +  c  *  h 

90225132 

z(k,i)  -  c  *  z  (k, i)  -  s  *  h 

90225133 

180 

continue 

90225134 

90225135 

200 

continue 

90225136 

90225137 

e(l)  »  s  *  p 

90225138 

d  (1)  -  c  *  p 

90225139 

if  (dabs(e(l))  .gt.  b)  go  to  130 

90225140 

220 

d ( 1 )  -  d(l)  +  f 

90225141 

240 

continue 

90225142 

**********  order  eigenvalues  and  eigenvectors  ********** 

90225143 

do  300  ii  -  2,  n 

90225144 

i  -  ii  -  1 

90225145 

k  -  i 

90225146 

p  -  d(i) 

90225147 

90225148 

do  260  j  -  ii,  n 

.90225149 

if  (d(j)  .ge.  p)  go  to  260 

90225150 

k  -  j 

90225151 

p  -  d( j) 

90225152 

260 

continue 

90225153 

90225154 

if  (k  .eq.  i)  go  to  300 

90225155 

d(k)  -  d(i) 

90225156 

dUI  -  P 

90225157 
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c 


280 

c 

300 

c 

c 

c 

1000 

1001 

c 

c 

c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

n 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


do  280  j  -  1,  n 
p  “  2 ( j, i) 
z(j,i)  -  z(j,k) 

Z(j,k)  -  p 

continue 
continue 
go  to  1001 

**********  Set  error  —  no  convergence  to  an 

eigenvalue  after  30  iterations  ********** 

ierr  -  1 
return 

**********  last  card  of  tql2  ********** 
end 


subroutine  trbak3 (nm, n, nv,  a,m, z) 

integer  i, j, k, l,m, n, ik, iz, nm, nv 
double  precision  a (nv) , z (nm, m) 
double  precision  h,s 

this  subroutine  is  a  translation  of  the  algol  procedure  trbak3, 
num.  math.  11,  181-195(1968)  by  martin,  reinsch,  and  wilkinson. 
handbook  for  auto,  comp.,  vol . ii-linear  algebra,  212-226(1971). 

this  subroutine  forms  the  eigenvectors  of  a  real  symmetric 
matrix  by  back  transforming  those  of  the  corresponding 
symmetric  tridiagonal  matrix  determined  by  tred3. 

on  input- 

nm  must  be  set  to  the  row  dimension  of  two-dimensional 
array  parameters  as  declared  in  the  calling  program 
dimension  statement, 

n  is  the  order  of  the  matrix, 

nv  must  be  set  to  the  dii .  nsion  of  the  array  parameter  a 
as  declared  in  the  calling  program  dimension  statement, 

a  contains  information  about  the  orthogonal  transformations 
used  in  the  reduction  by  tred3  in  its  first 
n*(n+l)/2  positions, 

m  is  the  number  of  eigenvectors  to  be  back  transformed, 

z  contains  the  eigenvectors  to  be  back  transformed 
in  its  first  m  columns. 

on  output - 

z  contains  the  transformed  eigenvectors 
in  its  first  m  columns. 

note  that  trbak3  preserves  vector  euclidean  norms. 

questions  and  comments  should  be  directed  to  b.  s.  garbow, 
applied  mathematics  division,  argonne  national  laboratory 
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c 

29445049 

if  (m  .eq.  0)  go  to  200 

29445050 

if  (n  .eq.  1)  go  to  200 

29445051 

c 

29445052 

do  140  i  -2,  n 

29445053 

1  -  i  -  1 

29445054 

iz  -  (i  *  1)  /  2 

29445055 

ik  -  iz  +  i 

29445056 

h  -  a(ik) 

29445057 

if  (h  .eq.  0.0)  go  to  140 

29445058 

c 

29445059 

do  130  j  -  1,  m 

29445060 

s  -  0 . 0 

29445061 

ik  -  iz 

29445062 

c 

29445063 

do  110  k  =  1,  1 

29445064 

ik  -  ik  +  1 

29445065 

s  =  s  +  a(ik)  *  z(k,j) 

2944506 6 

110 

continue 

29445067 

c 

**********  double  division  avoids  possible  underflow  ********** 

29445068 

s  -  (s  /  h)  /  h 

29445069 

ik  =  iz 

29445070 

c 

29445071 

do  120  k  -  1,  1 

29445072 

ik  -  ik  +  1 

29445073 

100 

z  (k,  j)  -z  (k,  j)  -s*a  (ik) 

120 

continue 

29445075 

c 

29445076 

130 

continue 

29445077 

c 

29445078 

140 

continue 

29445079 

c 

29445080 

200 

return 

29445081 

c 

**********  last  card  of  trbak3  ********** 

29445082 

end 

29445083 

subroutine  lister (ino, jno) 
c  polylbls  program  —  mom  master  file  log 

c  initial  creation  —  4/8/74  —  bdo 

c  cit  integral  list  generation  program-based  on  polyatom  pa20 
integer  pkdlbl 
character*16  naml 
character*ll  moll2,mol05,mol02 

dimension  ma(l90,50),mb(180,50),ia(180),ib(180), nam(4) , ilbl (20) 
l,moll2 (20) ,mol05 (20) ,mol02 (20) 
real *8  tymes, xtyme (2) 
dimension  tyme(2) 

common/ndata/nbfn, nbfo, ntrn,  ntrnpt,  nadd, ntape 
common/ioind/icon (10) ,mrec, izero, ione 
common/ label /pkdlbl (1024) 

data  nam/4hslst, 4htlst, 4hvlst,  4hmlst/f mxbf /180/,mxtr/50/ 
izero-0 
ione-1 
mrec-1024 
ntape- 3 
c 

-  ******************************************************************* 


mol 12 (1) -'mol 12 01 . dat' 
mol 12 (2) -'moll202.dat' 
mol 12 (3) -'moll203.dat' 
moll2 (4) -'moll 2 04 .dat' 
mol 12 (5) -'mol 1205 . dat' 
mol 12 (6) «'moll206 .dat' 
mol 12 (7)-'moll207 .dat' 
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mol 12 (8) -'moll208.dat' 
moll2 (9) -'moll209.dat' 
moll2(10)-'moll210.dat' 
moll2 (11) -'moll211.dat' 
moll2(12)-'moll212.dat' 
moll2(13)-'moll213.dat' 
moll2 (14) -'moll214.dat' 
mol 12 (15) *' mol 12 15.dat' 
moll2 (16) *'moll216 .dat' 
moll2 (17) -'moll217 .dat' 
mol 12 <18)-'moll218.dat' 
moll2 (19) -'moll219.dat' 
moll2(20)-'moll220.dat' 
mol02(l) -'mol0201.dat' 
mol 02 (2) -'mol0202.dat' 
mol02(3)-'mol0203.dat' 
mol 02 (4)-'mol0204.dat' 
mol02(5)«'mol0205.dat' 
mol02 (6) -'mol0206.dat' 
mol 02  (7) -'mol 02 07.  dat' 
mol02 (8) -'mol0208 .dat' 
mol02 (9) -'mol0209 .dat' 
mol 02 (10) “'mol 02 10 .dat' 
mol 02 (11) “'mol0211.dat' 
mol02(12)»'mol0212.dat' 
mol02 (13) -'mol0213.dat' 
mol 02 (14) «'mol0214 . dat' 
mol02 (15) -'mol0215.dat' 
mol02 (16) -'mol0216.dat' 
mol 02 (17) «'mol0217 .dat' 
mol 02 (18) ~'mol0218 .dat' 
mol02(19)-'mol0219.dat' 
mol02 (20) »'mol0220 .dat' 
mol05(l)-'mol0501.dat' 
mol05 (2) -'mol0505.dat' 
mol05 (3) -'mol 050 3 .dat' 
mol 05 (4) »'mol0504 .dat' 
mol05 (5) -'mol0505.dat' 
molOS (6) -'mol0506.dat' 
mol05 (7) -'mol0507.dat' 
mol05 (8) »'mol0508 .dat' 
mol05 (9) -'mol 0509 .dat' 
mol05 (10) -'mol0510.dat' 
mol05 (11) -'mol0511.dat' 
mol05 (12) -'mol0512.dat' 
mol 05 (13) -'mol0513.dat' 
mol05 (14) -'mol0514 .dat' 
mol05 (15) -'mol0515.dat' 
mol05 (16) -'mol0516.dat' 
mol 05 (17) -'mol0517.dat' 
mol 05 (18) -'mol0518 .dat' 
mol 05 (19) -'mol0519.dat' 
molOS (20) -'mol0520.dat' 

open (unit-5f  f ile-moll2 (ino) ,  form-' formatted' ) 
open (unit-60, f ile-mol05 (ino) , form-' formatted' ) 
open (unit-ntape, file-mol02 (ino) , 

1 form-' unformatted' ) 
c  read  in  input  data  for  this  run 

call  inlab (ma,mb, ia, ib,mxbf , mxtr, ilbl) 
c  the  matrix  of  transformation  properties  from  this  routine  is  ready 
c  to  use  at  this  point 
rewind  ntape 
write (ntape)  ilbl 
write (ntape)  nbfn 

7  C7 


lopas.sub  Fri  Apr  5  11:22:53  1991  174 

c  write(ntape)  nbfn, ntrn, ntrnpt, ( (ma(i, j) ,  j-1, ntrn) , i-1, nbfn) 
ndo-ntrn 
do  60  k-1,3 
write (ntape)  nam(k) 
if(k.eq.3)  ndo-ntrnpt 

c  get  list  for  one  electron  integrals-use  only  molecular  point  group 
c  for  the  potential  energy  integral  list 
60  call  olist (ma,mb, ia, ib,mxbf ,mxtr, ndo) 
write (ntape)  nam(4) 
if (icon (1) . ne . 0)  go  to  75 

c  the  two  electron  integral  list  is  now  produced 
call  tlist (ma,mb, ia, ib,mxbf ,mxtr) 

75  endfile  ntape 
rewind  ntape 

1000  format (lx, ' enter  the  name  of  the  labels  input  file  (file  5)') 

1100  format (al6) 

1200  format (lx, ' enter  the  name  of  the  labels  information  output  file', 
1'  (file  6)') 

1300  format (lx, 'enter  the  name  of  the  labels  output  file  (file  3)') 
close (unit-ntape) 
close (unit-5) 
close (unit-60) 

1400  format (lx, f 18 . 4, 4x, f 18 . 4 ) 
return 
end 

c 

Q  ******************************************** 

C 

subroutine  inlab (ma,mb, ia, ib,mxbf ,mxtr, ilbl) 
dimension  ma (mxbf , 1) ,mb (mxbf , 1)  ,  ia (1) , ib (1) , ilbl (1) 
dimension  ngroup(180) 

common  /ndata  /  nbfn,  nbfo,  ntrn,  ntrnpt,  nadd, ntape 

common  /ioind  /  icon  (10) 

read (5, 930)  (ilbl (i) , i-1, 20) 

read  (5,913)  icon 

read  (5,905)  nbfo,  nbfn 

re,-i(5,  905)  (ia  (i) , i-1 , nbfo) 

r.  ai(5,905)  ntrn, ntrnpt, nadd 

write (60, 600) 

write (60, 610)  (ilbl (i) , i-1 , 20 ) 
write (60, 620)  icon 
write (60, 630)  nbfo, nbfn 
write (60, 640)  ntrn, ntrnpt, nadd 
k-0 

do  12  i-1, nbfo 
if  (ia (i) .eq. 0)  ia(i)«l 
12  k-k+ia (i) 

if (nbfn. le. mxbf .and. nbfo. le. nbfn)  go  to  701 
write  (60, 800) 

write (60, 801)  nbfo, nbfn, mxbf 
stop 

701  if (nbfn.eq.k)  go  to  702 
write (60, 800) 

write (60, 802)  nbfn,k 
stop 

702  if (ntrn. le.mxtr. and. ntrnpt. le.mxtr)  go  to  703 
write (60, 800) 

write (60, 803)  ntrn, ntrnpt, mxtr 
stop 

703  continue 
if  (ntrn.eq. 0)  return 
write (60, 912)  nbfo, ntrn 
do  52  i-1, nbfo 

read(5,905)  (ma (i, j) , j-1, ntrn) 
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do  350  j-l,ntrn 
350  mb(i, j)-ma(i, j) 

52  write  (60,  910)  (ma  (i,  j) ,  j-1,  ntrn) 

c  A******************************************* 

c  check  to  see  that  same  number  does  not  occur  twice  in  a  column 
if (nbfo. le. 1)  go  to  1740 
do  1741  j-1, ntrn 
do  1742  i«2,nbfo 
if (ma (i, j) .eq. 0)  go  to  1742 
itest-iabs (ma  (i, j) ) 
iml-i-1 

do  1743  k-l,iml 
iz-ma (k, j) 

if (iabs (iz) .eq.itest)  go  to  1744 

1743  continue 
1742  continue 
1741  continue 

go  to  1740 

1744  continue 

write (60, 1750)  j,i,k 

1750  format (///5x,7hcolumn  ,i3,22h  rows  with  same  class  ,2i5) 
stop 

1740  continue 
c 

Q  A******************************************* 

c  now  the  operations  read  in  are  multiplied  together  to  produce  a 
c  group 

c  a  new  operation  is  checked  and  added, then  multiplied  with  all  old 
c  ones 

c  all  multiplications  with  the  set  of  operations  in  the  matrix  are 
c  tried  before  adding  a  new  element 

c  if  point  group  operations  precede  local  symmetry  operations-all 

c  point  group  operations  will  occur  before  any  local  sym  op-this  is 
c  program  expects  it 

if (icon(2) .ne.0)  go  to  340 
limit-0 

do  200  i-l,ntrn 
j-limit 
j  j-0 

do  110  k«l,nbfo 
110  ib  (k) -ma  (k,  i) 

if ( i — 1 )  50,50,120 
115  j-j+1 

j  j-o 

125  jj-jj+1 

do  10  k«l,nbfo 
ib (k) -0 
m-mb (k, j) 

1  -  iabs (m) 

if  (  1  .eq.  0  )  go  to  10 
ib (k) «m/l*mb (1, j j) 

10  continue 

c  check  against  previous  transformations-then  identity  element 
120  do  30  ij-1, limit 

do  20  k-l,nbfo 

if (ib (k) . ne.mb(k, i j) . and. ib (k) .ne . 0)  go  to 
20  continue 

go  to  70 
30  continue 

do  40  k-l,nbfo 

if <ib(k) . ne . k. and. ib (k) .ne.0)  go  to  50 
40  continue 

go  to  70 
50  limit-1 imit+1 
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if (limit. le.mxtr)  go  to  704 
write (60, 800) 
write (60, 804)  mxtr 
stop 

704  continue 

do  60  k-l,nbfo 
60  mb  (Jc,  limit)  -ib(k) 

70  if(jj.lt.j)  go  to  125 
if ( j . It . limit)  go  to  115 
ngroup (i) "limit 
200  continue 
nrdin-ntrn 
ntrn-limit 

write (60, 912)  nbfo,ntrn 
do  102  i-l,nbfo 

102  write (60, 910)  (mb (i, j) , j-1 , ntrn) 
c  check  for  zeroes  in  point  group  part  of  transformation  matrix 
if (icon (7) . ne . 0)  go  to  7064 
c  set  no  transformations  in  point  group 
nhi«0 

do  7061  i-l,nrdin 

nlo-nhi+1 

nhi-ngroup(i) 

do  7062  ii-nlo,nhi 

do  7063  k-l,nb£o 

if (mb (k, ii) . eq. 0)  go  to  7065 

7063  continue 
7062  continue 
7061  continue 

nlo-nhi+1 

7065  continue 
ntrnpt-nlo-1 
go  to  7066 

7064  continue 

if (ntrn.ge.ntrnpt)  go  to  705 

write (60, 800) 

write (60, 805)  ntrn,ntrnpt 

stop 

705  continue 

if (ntrnpt . eq. 0)  go  to  7066 
do  7067  i-l,nrdin 

if (ntrnpt .eq. ngroup (i) )  go  to  7066 
7067  continue 

write  (60, 2742)  ntrnpt 

2742  format (//5x, ' ntrnpt-  ' , i5, 5x, ' does  not  form  a  group') 
stop 

7066  continue 

write (60, 578)  ntrnpt 

578  format (/5x, 25hno  trns  in  point  group-  ,i5) 
if (nadd.eq. 0 . or . ntrn . le . nadd)  go  to  706 
write (60, 800) 
write (60, 806)  ntrn,nadd 
stop 

706  continue 

c  ******************************************** 

c 

Q  A***************************************** 

c  expand  tr  matrix 

340  ib(l) -0 

do  250  i-2, nbfo 
250  ib(i) -ib(i-l) +ia ( i — 1 ) 
do  140  i-l,nbfn 
do  140  j-1, ntrn 
140  ma (i,  j)-0 
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do  15  i-l,nbfo 
jmx-ia (i) 
do  15  k-l,ntrn 
nkr-mb  (i,  k) 
nk-iabs (nkr) 
nnk-nkr 

if(nkr.eq.O)  go  to  15 

if ( jmx.eq.ia (nk) )  go  to  707 

write (60, 800) 

write (60, 807)  i,nk 

stop 

707  continue 

do  14  j-1,  jinx 
nnbf-ib(i) +  j 

14  ma (nnbf , k) «nnk/nk* (ib (nk) + j) 

15  continue 

write (60, 912)  nbfn,ntrn 
do  31  i-1, nbfn 
ia(i)«(i* (i-1) )/2 

31  write (60, 910)  (ma  (i,  j) , j-1, ntrn) 

******************************************** 

return 

800  format (///5x, 30hlabel  program  fatally  wounded  /) 

801  format (5x,  17hnclass, nbf,maxbf  ,3i5) 

802  format (5x, 23hnbf, sum  of  expand  list  ,3i5) 

803  format (5x, 18hntrn, ntrnpt, maxtr  ,3i5) 

804  format (5x, 29htoo  many  trs  generated-maxtr-  ,3i5) 

805  format (5x, 27hnot  enough  trs-ntrn, ntrnpt  , 3i5) 

806  format (5x, 18hntrn, ntr  expected  ,3i5) 

807  format (5x, 8hclasses  ,2i3,32h  have  unequal  no  of  fctns 

600  format (lhl//5x, 26hlabel  generation  program  ) 

610  format (//5x,  20a4) 

620  format (/5x, 8hoptions  ,10i3) 

630  format (/5x, 20hno  classes  of  fctns-  ,i3/5x,16hno  basis  fctns-  ,i3) 

640  format (/5x, 22hno  symmetry  elements-  ,i3/5x,19hno  in  point  group- 
xi3/5x,22hno  elements  expected-  ,  i3) 

905  format  (2413) 

910  format (5x, 24i5) 

912  format (//5x,  21htransf ormation  matrix  , 5x, 4hnbf-, i4, 3x, 5hntrn», i4/ 
913  format  (  10i5  ) 

930  format (20a4) 
end 

******************************************** 

subroutine  olist (mtrans, list, itemp, nos, mxbf , mxtr, ntrn) 
integer*2  ii (1024) , j j (1024) , itg(1024) 

dimension  mtrans  (180,  50) ,  nos  (180),list(180,50),  itemp(180) 

common  /ndata  /  nbfn,  nbfo,  ndum,  ntrnpt,  nadd,ntape 

common/ioind/icon (10) ,mrec,  izero,  ione 

common/ label /pkdlbl (1024) 

ntot-0 

nztg-0 

nxtpk-0 

iflst-0 

list (1, 6) — 0 

do  25  i-1, nbfn 

list (1, 1) -i 

do  25  j-l,i 

list (1, 2) - j 

nofild-1 

if  (  ntrn  )  11,23,11 

11  ip-itemp(i) + j 

do  22  m-1. 


ntrn 
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it  - 

mtrans (i,m) 

jt  - 

mtrans ( j,m) 

iprdt 

-  it*  jt 

itag  < 

-  1 

if  ( 

iprdt  )  12 

12 

itag  1 

-  2 

13 

it  - 

iabs (it) 

jt  - 

iabs ( jt) 

if  ( 

it  -  jt  ) 

14 

mx  - 

it 

it  - 

jt 

jt  - 

mx 

12,22,13 


14,15,15 


15  ipt-itemp(it) + jt 

if (ip-ipt)  17,16,25 

16  if (iprdt)  25,22,22 

17  if  (nof ild-2)  21,18,18 

18  do  20  ic-2,nofild 

if (ipt-nos (ic) )  20,22,20 

20  continue 

21  nof ild-nof ild+1 
nos (nof ild) -ipt 
list (nofild, 1) -it 
list (nofild, 2) - jt 
list (nofild, 6) -itag 

22  continue 

23  nztg-nztg+1 

do  1310  m-1,  nofild 
if (nxtpk-mrec)  310,316,316 
316  write (ntape)  nxtpk, izero, ii, j j, itg 
ntot-ntot+nxtpk 
nxtpk-0 

310  nxtpk-nxtpk+1 

ii (nxtpk) -list (m, 1 ) 
j j (nxtpk) -list (m, 2) 
itg (nxtpk) -list (m, 6) 

1310  continue 
25  continue 

write (ntape)  nxtpk, ione, ii, jj, itg 
ntot-ntot+nxtpk 
write (60, 456)  nztg,ntot 
456  format (/5x, 30hno  labels-unique  and 
return 
end 


total 


,  2  i  1 0  ) 


c 

£  ******************************************** 

c 

subroutine  tlist (mtrans, list, iiml, nos,mxbf ,mxtr) 
c  this  routine  takes  all  the  time  of  label  creation 

integer*2  ii (1024) ,  jj (1024) , kk (1024) , 11  (1024) , itg (1024) , muu (1024) , 
lmun (1024) 

dimension  mtrans (I80,50),list(180,50),nos(180), iiml (180) 
common/label/pkdlbl (1024 ) 

common  /ndata  /  nbfn,  nbfo,  ntrn,  ntrnpt,  nadd, ntape 
common/ioind/icon (10) ,mrec, izero, ione 
data  nxtpk/0/,nztg/0/,ntot/0/, ifirst/1/ 
c  icon(3).ne.O  used  for  adding  basis  functions  to  set 
c  icon(5).ne.O  used  for  calculating  integrals  for  an  ivo  calculation 

if (icon(3) .gt.0)  ifirst-icon (3) 
kfb-1 

if (icon(4) .ne.0)  kfb-ifirst 

inew-icon(S) 

list (1,6) -0 

do  38  i-ifirst,nbfn 

list (1, 1) -i  - 
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do  36  j-l,i 

list (1/ 2) - j 

ij2-iiml(i)+j 

ij4-(ij2*(ij2-l))/2 

kfa-1 

if { j . It . ifirst)  kfa-kfb 
do  34  k-kfa,i 
list (1, 3)  -k 
if(i-k)  12,11,12 

11  lmx-j 

go  to  13 

12  lmx-k 

13  do  32  1-1,  lmx 
list  <1 , 4 ) -1 

if (inew.eq. 0)  go  to  3636 
nnew-0 

if (i .ge. inew)  nnew-nnew+1 
i f ( j . ge . inew )  nnew«nnew+ 1 
if (k.ge. inew)  nnew-nnew+1 
if  (1  .ge .  inew)  nnew-nnew+1' 
if (nnew.gt.2)  go  to  32 
3636  continue 
nofild-1 

if(ntrn)  14,31,14 

14  ip-i j4+iiml (k) +1 
do  30  m-l,ntrn 
it-mtrans (i,m) 
jt-mtrans ( j,m) 
kt-mtrans (k,m) 
lt-mtrans (l,m) 
iprt-it* jt*kt*lt 
itag-1 

if(iprt)  15,30,16 


15  itag-2 


16 

it-iabs (it) 
jt-iabs ( jt) 
kt-iabs (kt) 
lt-iabs (It) 
if  (it- jt)  17,18, 

,18 

17 

mx  » 

it 

it  - 

jt 

jt  - 

mx 

18 

if  ( 

kt  -  It  )  19,20,20 

19 

mx  - 

kt 

kt  - 

It 

It  - 

mx 

20 

if  ( 

it  -  kt  )  22,21,23 

21 

if  ( 

jt  -  It  )  22,23,23 

22 

mx  - 

it 

it  - 

kt 

kt  - 

mx 

mx  - 

jt 

jt  - 

It 

It  -  mx 

23 

ijt  - 

iiml(it)  +  jt 

kit  - 

iiml(kt)  +  It 

ipt- (i jt* (i jt-1) ) /2+klt 

if  (ip  -  ipt  )  25,24,32 

24  if(iprt)  32,30,30 

25  if (nofild-2)  29,26,26 

26  do  27  ic-2,nofild 

if (ipt-nos(ic) )  27,30,27 

27  continue 

29  nofild-nofild+1 
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noa (nofild) -ipt 
list (nofild, 1) -it 
list (nofild, 2) - jt 
list  (nofild,  3)  -kt 
list (nofild, 4) -It 
list (nofild, 6) -itag 

30  continue 

31  nztg-nztg+1 

do  245  m-1, nofild 
if (nxtpk-mrec)  310,316,316 

316  write (ntape) nxtpk, i zero, ii, j j, kk, 11, itg,muu 
ntot-ntot+mrec 
nxtpk-0 

310  nxtpk-nxtpk+1 

if (list (m, 2) -list (m, 3) )  210,220,230 

210  if (list (m, 2) -list (m, 4) )  211,214,217 

211  if (list (m, 3) -list (m, 4) )  199,212,213 

212  mun  (m)  -8 
go  to  240 

213  mun (m) -14 
go  to  240 

214  if (list (m, 1 ) -list (m, 3) )  199,215,216 

215  mun(m)-2 
go  to  240 

216  mun (m) -11 
go  to  240 

217  if (list (m, 1) -list  (m,  3) )  199,218,219 

218  mun (m) -10 
go  to  240 

219  mun (m) -13 
go  to  240 

220  if (list (m, 3) -list (m,  4) )  199,221,224 

221  if (list (m,l) -list (m,2) )  199,222,223 

222  mun(m)«l 
go  to  240 

223  mun(m)-6 
go  to  240 

224  if (list (m, 1) -list (m,  2) )  199,225,226 

225  mun(m)«4 
go  to  240 

226  mun(m)«9 
go  to  240 

230  if (list (m, 1) -list (m, 2) )  199,231,234 

231  if (list (m, 3) -list (m, 4) )  199,232,233 

232  mun (m) -3 
go  to  240 

233  mun (m) -5 
go  to  240 

234  if (list (m, 3) -list (m, 4) )  199,235,236 

235  mun(m)-7 
go  to  240 

236  mun (m) -12 

240  continue 

ii (nxtpk) -list (m,  1) 
j j (nxtpk)-list (m, 2) 
kk (nxtpk) -list (m,  3) 

11 (nxtpk) -list (m,  4 ) 
itg (nxtpk) -list (m, 6) 
muu (nxtpk) -mun (m) 

245  continue 

32  continue 
34  continue 
36  continue 
38  continue 


lopaa . sub 


fri  Apr  5  11:22:53  1991 


181 


ntot-ntot+nxtpk 

write  (ntape)  nxtpk,  ione,  ii,  j j, kk,  11/ itg,muu 
write (60, 456)  nztg,ntot 
456  format (/5x, 30hno  labels-unique  and  total 
return 

199  write(60, 145)  (liat (m, ku) , ku»l, 4) 

145  format (/5x, 'error  in  mlist  -i,j,k,l  ',4i5) 
atop 
end 


,  2il0) 


APPENDIX  D 

LISTING  OF  THE  MAIN  LOPAS  PROGRAM 
PARALLEL  PROCESSOR  VERSION 


A.  B.  Kunz ,  Author 


deservenbarry . 
parlop.f 

Tue  Feb  26  10:37:48  1991 
Iw  /  TCD  LaserWriter  II  NT 


lw 

deserver : barry 

Job: 

parlop. f 

Date: 

lw 

deserver : barry 

Job: 

parlop . f 

Date: 

lw 

deserver : barry 

Job: 

parlop. f 

Date: 

lw 

deserver: barry 

Job: 

parlop. f 

Date: 

Vfl 


Tue  Feb  26  10:37:48  1991 
Tue  Feb  26  10:37:48  1991 
Tue  Feb  26  10:37:48  1991 
Tue  Feb  26  10:37:48  1991 


C  This  is  an  implementation 

C  of  local  orbitals  procedures  of 

C  Adams,  Gilbert  and  Kunz  implemented 

C  for  cluster  building  blocks  and 

C  a  gaussian  basis  set 

C  part  of  the  MEGAMOL  sequence 

C  Molecules  for  the  90' s 

C  author  is  A  B  Kunz 

C  Michigan  Technological  University 

C  College  of  Engineering 

C  Fortran  77 

C  written  1991 

C  written  for  parallel  computers  using  the  cosmic  environment 

C  all  rights  reserved  by  the  author 

c  ★  ★♦★★★★★★★★★★★★★★★************,************xxxxir*x***x*xxx*xxxF  «  r  * 

C 

Program  lopas 

r 

Q  ★  ★★★★★★★★★★★★★★★★★★★★★★★★★*****,*'**'*'*-****************-*******XX.<rT*XX 

c 

implicit  real*8  (a-h, o~z ) 
dimension  nenv(20) , id(20, 200) , • 
ltrans (85) ,xof (20,200)  ,yof (20,200) ,zof (20,  200)  , 

2a  (20, 200) ,b (20, 200) ,c  (20, 200) 
real *4  tyme(2) 
real*8  norm 

common/angle/angl (73)  ,  cangl (73) , sangl (73) 
common /pparms /all, any, iid, ipid, isiz , izro 
character*ll  mol41(20) 
integer  all, any 


1  format (i4) 

2  format ( '  THIS  IS  A  GAUSSIAN  BASIS  SET  LOPAS  CALCULATION  ',/, 
1'  USING  THE  MULTI  CENTER  METHOD  OF  A  B  KUNZ  ',/, 

2'  FOLLOWING  THE  PROCEDURE  Or  ADAMS -GILBERT -KUNZ  ') 

3  format (lx,'  nbb  =  '  ,  i 4 ) 

4  format (i4) 

5  format (i4, 6x, 6£10 . 4) 

6  format (lx,'  nenv(i)  =  ',14) 

l  format (lx, '  id  =  ',i4,'  xof  =  ',fl0.4,'  yof  =  ',fl0.4, 

1'  zof  -  ' , f 10 . 4 , / , '  ancle  I  =  ',fl0.4,'  ancle  2  -  ',f!0.4, 
2'  angle  3  =  '  ,fl0.4) 

3  format  (lx,'  CPU  run  time  is  ',fl6.3,'  sec  ') 


mol41 (l)-'mol4101 .dat' 
mo!41 (2) -'mo 14102 .dat' 
mol41 (3 ) -' mo 14103 .dat ' 
mol 41 (4)=' mol 4 104 .dat' 
mol 41 (5) -'mol 4 105 .dat' 
mo 141 (6)='mol4106 .dat' 
mol41(7)-'mol4107 .dat' 
mol 41 (8) -'mol 4 108 .dat' 
mol41(9)-'mol4109 .dat ' 
mo 141 (10) -'mol4110.dat' 
mol41 (11) -' mo 14111. dat' 
mol 41 (12)-' mo 14112. dat' 
mol41 (13)-' mo 14113. dat' 
mol41 (14) -'mol4114.dat' 
mo 141(15)-' mol4115. dat' 
mo 141 (16) -'mol4116.dat' 

-..I  di  A-**  > 


'/bZ, 


c 

c 

c 

c 

c 


mol 41 (18) -'mo 14118 .dat' 

mol 41 (19)-' mo 14119. dat' 

mol 41 (20)-'mol4120 .dat' 

iid-mynode ( ) 

isiz-nnodes ( ) 

ipid-mypid() 

all— 1 

any— 2 

izro-0 

if (iid.eq.O)then 

open (unit-60, file-'mol5e . dat'  ,  form-'  formatted' ) 
open (unit =14, file-' moll 4 . dat' , form-' formatted' ) 


C  define  local  orbitals  problem 

C 

read (14, 1) nbb 
write  (60,2) 
write (60,3) nbb 
print  2 
print  " . nbb 
do  20  _=l,nbb 
read(14, 4) nenv(i) 
do  20  j=l,nenv  (i) 

read  (14, 5)  id(i,  j) ,  xof  (i,  j  j ,  yof  (i,  j) ,  zof  (i,j),a(i,j),b(i,j),c(i,  ;) 

20  continue 

do  21  i=l,nbb 
write (60, 6) nenv  (i) 
print  6,nenv(i) 
do  21  j=l,nenv(i) 

write (60, 7) id(i, j) , xof (i, j) , yof (i, j) , zof (i, j) , a (i, j ) , b (i, j) , c ( i , j ) 

21  print  7,id(i,  j) , xof (i,  j ) , yof (i,  j) , zof (i, j ) , a (i, j),b(i,j),c(i, ;) 

C  lopas  set  up  data  done  now 

2  Do  local  orbital  buildingblccks  in  free  space  now 


broadcast  nbb, nenv, id, xof , ycf , zof , a, b, c  here 
do  60  ii=l,isiz-l 
nm-100*ii+l 
1-4 

call  frecv (i j , 1, nm, ii, ipid) 
if (ij .ne. ii) stop  '  par  punt  ' 
nm-nm+1 
1-4 

call  fsend(nbb, 1, nm, ii, ipid) 
nm-nm+1 
1-80 

call  fsend(nenv, 1, nm, ii, ipid) 
nm-nm+1 
1-16000 

call  fsend(id, 1, nm, ii, ipid) 
nm-nm+1 
1-32000 

call  fsend(xof, l,nm, ii, ipid) 
nm-nm+1 

call  fsend(yof , 1, nm, ii, ipid) 


call  f send (zof , 1, nm, ii, ipid) 
nm-nm+1 

call  fsend(a, 1, nm, ii, ipid) 
nm-nm+1 

call  fsend(b, 1, nm, ii, ipid) 
nm-nm+1 

call  fsend(c, 1, nm, ii, ipid) 

60  continue 
else 

nm-iid*100+l 

1-4 

call  fsend(iid, 1, nm, izro,  ipid) 

nm-nm+1 

1-4 

call  frecv (nbb, 1, nm, izro,  ipid) 
nm-nm+1 
1-80 

call  frecv (nenv, 1, nm, izro,  ipid) 
nm-nm+1 
1-16000 

call  frecv (id, 1, nm, izro, ipid) 

nm-nm+1 

1-32000 

call  f recv (xof, 1, nm, izro,  ipid) 
nm-nm+1 

call  frecv (yof, 1, nm, izro,  ipid) 
nm-nm+1 

call  frecv ( zof , 1, nm, izro,  ipid) 
nm-nm+1 

call  frecv (a, 1, nm, izro, ipid) 
nm-nm+1 

call  frecv (b, 1, nm, izro,  ipid) 
nm-nm+1 

call  frecv (c, 1, nm, izro, ipid) 

endif 

ilop-0 

do  30  i-iid+1, nbb, isiz 

C  $$$$$$$ $$$$$$$$ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ $$$$$$$$$ 

C’****this  is  a  par-do 

C  $$$$$$$$$$$$$$$$$$$$$$$$$ $$S$S$$S$S$$S$S$$35$S$$$ $$$$$$$$$5$ 

call  lister (i, ilop) 
call  poly (i, ilop) 
call  uhf(i,ilop) 

30  continue 

if (iid. ne . 0 ) then 

nm-200*iid 

1-4 

call  f send ( iid, 1, nm, izro, iprd) 
else 

do  70  ii-l,isiz-l 

nm-ii*200 

1-4 

call  frecv ( ij , 1, nm, ii, ipid) 
if(ij.ne.ii)  stop  '  par  punt  two  ' 
call  fkill ( ii, ipid) 

70  continue 

tymes-etime (tyme) 
print  9,tyme(l) 
write (60, 8) tyme (1) 

if (ilop.eq.0)  stop  '  done  for  now  ' 

**********.  ******..,..*„* . *yj.*j******  *******  *  +  ****’”- 


c 


o  o  o  o  o 


free  space  estimates  of  building  blocks  are 
evaluated  here 

get  multipole  moments  and  begin  Icpas  rotations 

★  ★★★★★★★★★★★★★★★★★★★★★★★★★★******'»**************************x-*  *  x  *  *  x  ir 

do  9999  ilps-1,4 
ilop-ilps 

evaluate  moments  of  each  lopas  block  here 
evaluate  detailed  potentials  as  well 
do  40  i-iid+1, nbb, isiz 

$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$3$$$$$$$$$$$$$$$$$$$$$$$$ 

C*'***thiS  is  a  par-do 

C 

C  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$3333$$$$$$$$$$$$$$$$$$$$$$$ 

C 

40  call  moments (i, ilps) 


—  ********************************irtt'it******i**************#***x*»Mlnxx 

c 

c  broadcast  needed  moments  data  to  each  other  processor  now 

c 


do  80  i=l,nbb 

open (unit-41, file-mol41 (i) , form-' unformatted' ) 

do  I  send  or  do  I  receive  data? 

if  i  -  iid  I  will  send 

otherwise  I  will  receive  data 

if(i.ne.iid)  go  to  81 

I  will  broadcast  data 

read(41)trans 

1=4 

nm=80 

do  82  ii-l,nbb 
if(i.eq.ii)  go  to  82 
call  frecv (i j ,  1, nm, ii, ipid) 

if (i j .ne. ii) stop  '  transfer  tilt  after  moments  ' 

1=680 

nm=81 

call  f send (trans, 1, nm, ii, ipid) 
continue 

all  data  sending  is  complete 

go  to  80 

continue 

receive  data  and  store  it 

1  =  4 

nm-80 

call  fsend(iid, 1, nm, i, ipid) 

1-680 

nm-81 

call  frecv (trans, 1, nm, i, ipid) 
write (41) trans 
close  (unit=41 ) 

t*#*lh^lHr***«tt***t*f****t**'iHr*<Mr*tT*f******ilf******ihkt****t**»**fjnt 

data  exchange  complete 

★  ★★★★★★★★★♦★★★★★★★★★★★★★★★■***xxxxxxxxx**ilr**x**,*****:*********x*xxxx 


print  19 


t- a  r>  r  *  a*  ~  q  <*-4  •  ->  *- 


L 


-  — 1  a 


r>  ri  *  •  0  0 


jar 


7  A  *T 


in 


nnonofin 


;  form  potential  of  environment  of  each  building  block 

do  50  i-iid+1,  nbb,  isiz 

$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
*****this  is  a  par-do 

$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 23$$$$$$$$$$$$$$$$$$$$$$$$$ 

call  pot (ilps, nenv, xof ,  yof , zof , a, b, c, i, id) 

print  18 

call  uhf(i,ilop) 

50  continue 
9999  continue 

close  (unit**61) 

stop  ' lopas  complete' 

end 

Subroutine  moments (ibb, ilpss) 

calculates  V00  potential  for  this  building  block 
calculates  moments  as  well 

uses  spherical  coordinates  and  3-d  numerical  quadrature 
authored  by  A  B  Kunz 
Fortran  77 

all  rights  reserved  by  the  author 

integrations  use  Weddle's  rule  over  angles 

integrations  use  Simpson' s  rule  over  r 

weighting  factors  are  used  to  define  each 

specific  integrations  properties  and  as  an 

aid  to  high  speed  computation.  This  reduces  each 

integral  to  a  dot  product,  and  facilitates  vectorization 

by  a  smart  compiler 

implicit  real*8 (a-h,o-z) 

dimension  rho (81,37,73),r(81),ril(37,73),ri2(73),wr(81), 

Iwal (37) , wa2 (73) , ntype (180),nfirst(180),nlast(180) , 

2fodm( 180, 180) ,tl  (218781) , t2  (213  781) , t3  (218781) , nr (20 
3,3) ,t5  (81, 37,73) ,t4  (81,  37, 73) , eta  (1024,  5) ,c(1024) 

4,ps (360) ,v(81),vl (81) ,v2(81) 
common/angle/angl (73) , cangl (73) , sangl (73) 
common/'mompot/vlist  (1024,  4)  ,  ncype,  niirst,  r.iasc,  era,  c 
real*8  norm 

reaiM  ain  ( 180)  , psi  (2, 180 , 180  ) 
characters  zl(20) 
character*15  mol51(20) 

character *11  mo 15a (20) , mo 111(20), mol04(20), mo 130(20), mo 141(2 
lmol40 (20) 

equivalence (t3 (1) , rho (1,1,1)) 
equivalence  (t4(l,l,l),tl(D) 
equivalence (t5(l, 1, 1) ,t2(l) ) 

data  nr  /  0,1, 0,0, 2, 0,0, 1,1, 0,3, 0,0, 2, 2, 1,0, 1,0,1, 

x  0,0, 1,0, 0,2, 0,1, 0,1, 0,3, 0,1, 0,2, 2, 0,1,1, 

x  0,0, 0,1, 0,0, 2, 0,1, 1,0, 0,3, 0,1, 0,1, 2, 2,1  / 


c 

c’ 

c 


★  ★  TT  ’ 


mo 1 5 1 (1) 
mol51 (2 ) 
mol51 (3) 
mox51  (4 ) 
mol51 (5) 
mol 51 (6) 
molSl (7) 
mol51 (8) 


' /work/psiOl .dat' 
' /work/psi02 .dat' 
' /work/psi03 .dat' 
' /work/psi04 .dat' 
' /work/psi05 .dat' 
' /work/psi06 .dat' 
' /work/psi07 .dat' 
' /work/psi08 .dat' 


bkk 


